XL 2010 extraire des onglets selon nom de l'onglet pour former un classeur distinct

[Caroline ;-))]

Bonjour,

J'ai un classeur qui contient 146 onglets (hé oui, vous avez bien lu). La plupart de ces onglets possède un nom du type :
"NomDeRegionX" (X est un chiffre)

==> Je souhaite faire une macro qui extrait les onglets qui débutent par un même nom de région et les mettent dans un classeur distinct (qui devrait porter le nom deladite région)

En gros, si j'ai 35 régions et je devrais avoir à la fin de la macro 35 classeurs, portant chacun le nom de la région)

J'ai une macro qui créée pour chaque onglet un classeur différent : (mais ce n'est pas ça que je souhaite)

Sub fichierDistinctParOnglet()
' chaque onglet devient 1 classeur
Dim ws
Dim newWk As Workbook

    For Each ws In Worksheets
        Set newWk = Workbooks.Add(xlWBATWorksheet)
        ws.Copy newWk.Sheets(1)
        newWk.SaveAs (ThisWorkbook.Path & "\" & ws.Name & ".xlsx") 'enregistrer automatiquement "les fichiers onglets" au même endroit que le fichier d'origine
        newWk.Close
        Set newWk = Nothing
    Next ws

End Sub

Pouvez-vous m'aider ?
Merci d'avance !

 

[sousou]

Bonjour
1 est-ce une manip répétitive?
Afin de déterminer ce qu'on fait des modèles et autres bdd

 

[pierrejean]

Bonjour Caroline
Salut sousou

Un essai

Sub test()
Set dico = CreateObject("Scripting.dictionary")
Set W = ThisWorkbook
For Each sh In W.Sheets
 If IsNumeric(Right(sh.Name, 1)) And InStr(sh.Name, "Modele") = 0 Then
    x = Left(sh.Name, Len(sh.Name) - 1)
    dico(x) = dico(x) & Right(sh.Name, 1) & ";"
 End If
Next
a = dico.keys
b = dico.items
For n = LBound(a) To UBound(a)
   Workbooks.Add
     y = Split(b(n), ";")
         For m = UBound(y) - 1 To LBound(y) Step -1
            ActiveWorkbook.Sheets.Add.Name = a(n) & y(m)
            Set Wb = ActiveWorkbook
            W.Activate
            W.Sheets(a(n) & y(m)).Select
            Cells.Select
            Selection.Copy
            Wb.Activate
            ActiveSheet.Cells.Select
            ActiveSheet.Paste
         Next
     ActiveWorkbook.SaveAs W.Path & "/" & a(n) & ".xlsx"
  Next
End Sub

 

[Caroline ;-))]

Oui, j'aurai à réaliser ces manips de manière récurrente.
1/ pour chaque onglet-modèle, j'aurai à générer des onglets par région (d'où l'utilité de la bdd "base de données")
2/ puis il faudra que j'envoie à chaque région, les onglets qui les concernent
Il faudrait donc, que je puisse conserver les onglets modèles et bdd (mais ce n'est pas un pb car avant de faire fonctionner la macro, j'aurai fait une sauvegarde de ma bdd et de mes modèles.)

En tout cas, merci de ton aide.

 

[Caroline ;-))]

Bonjour pierrejean, Bonjour sousou,

Merci pierrejean pour ton aide, mais seuls 15 classeurs ont été créés (sur les 35).
De plus est-il possible de faire un copier-coller valeur avant de réaliser cette extraction car mes calculs donnent 0 puisque mon onglet bdd n'est plus présent.
Est-il possible de refermer les classeurs avant la création du classeur d'une nouvelle région ? car tous les classeurs restent ouverts, c'est peut-être pour ça que seuls 15 classeurs aient été créés ? (pb de mémoire dispo ?)

A+

 

[sousou]

rebonjour et salut pierrejean
Je ne transmet que le code que j'ai mis dans un nouveau module (classeur gros)
Les classeurs seront créer dans le répertoire du fichier.
C'est un peu lent et long, mais cà semble fonctionner
début macro listerégions.
Public régions, r1
Sub listerégions()
chemin = ThisWorkbook.Path & "/"
Set régions = New Collection
For Each i In Sheets

If i.Index > 6 Then 'exeption des premières feuille
If existerégion(i.Name) = False Then régions.Add r1: Set classeur = Workbooks.Add: classeur.SaveAs (chemin & r1 & ".xlsx")
End If
Next
classeurs 'insertion des feuilles dans les classeurs
'Call voir(régions)
For Each c In Workbooks 'fermeture de tous les classeurs
If c.Name <> ThisWorkbook.Name Then
c.Close savechanges:=True
End If
Next

End Sub
'La région existe?
Function existerégion(r)
r1 = nrégion(r)
existerégion = False
For Each i In régions
If i = r1 Then existerégion = True: Exit Function
Next
End Function
'Dertermine le nom de la région
Function nrégion(k)
For n = Len(k) To 1 Step -1
caract = Mid(k, n, 1)
If IsNumeric(caract) = False Then
nrégion = Left(k, n)
Exit Function
End If
Next
End Function
'affichage des régions
Sub voir(collect)
For Each i In collect
phrase = phrase & i & Chr(13)
Next
MsgBox phrase
End Sub
'Ajouts des feuilles dans les classeurs
Sub classeurs()
For Each i In ThisWorkbook.Sheets
r = nrégion(i.Name)
If existerégion(r) = True Then
Set feuil = Workbooks(r & ".xlsx").Sheets.Add
feuil.Name = i.Name
i.UsedRange.Copy
feuil.Range("a1").PasteSpecial (3)
feuil.Range("a1").PasteSpecial (-4122)
End If
Next
End Sub

 

[pierrejean]

Re

Ceci a l'air de fonctionner

Sub test()
Set dico = CreateObject("Scripting.dictionary")
Set W = ThisWorkbook
For Each sh In W.Sheets
 If IsNumeric(Right(sh.Name, 1)) And InStr(sh.Name, "Modele") = 0 Then
    x = Left(sh.Name, Len(sh.Name) - 1)
    dico(x) = dico(x) & Right(sh.Name, 1) & ";"
 End If
Next
a = dico.keys
b = dico.items
For n = LBound(a) To UBound(a)
   Workbooks.Add
     y = Split(b(n), ";")
         For m = UBound(y) - 1 To LBound(y) Step -1
            ActiveWorkbook.Sheets.Add.Name = a(n) & y(m)
            Set Wb = ActiveWorkbook
            W.Activate
            W.Sheets(a(n) & y(m)).Select
            ActiveSheet.Range("C9:H18") = ActiveSheet.Range("C9:H18").Value
            Cells.Select
            Selection.Copy
            Wb.Activate
            ActiveSheet.Cells.Select
            ActiveSheet.Paste
         Next
     ActiveWorkbook.SaveAs W.Path & "/" & a(n) & ".xlsx"
     ActiveWorkbook.Close
  Next
End Sub

 

[Caroline ;-))]

Bonjour sousou et pierrejean,

SUPER ! Merci pour votre grande contribution à tous les 2 !
J'ai réalisé quelques adaptations mineures (expliciter les variables, fermer les classeurs créés)
Vous m'avez évité des heures de manips.
Vos 2 macros fonctionnent super bien. Je compte bien conserver vos 2 macros. Cela me permet d'apprendre.

Est-il possible de réaliser certaines modifications ?

MACRO de sousou : les classeurs de chaque région sont bien générés mais le 1er tableau est en dernière position (l'onglet le plus à droite) tandis que le tableau 4 est en 1ère position.

J'ai remplacé

i.UsedRange.Copy

par

i.UsedRange.Copy After:=Sheets(Sheets.Count)

mais cela ne marche pas

MACRO de pierrejean : la macro remplit son objectif : les classeurs de chaque région sont bien générés
Mais comment n'avoir que des résultats (c'est à dire faire un copier/coller valeur)

J'ai remplacé

ActiveSheet.Paste

par

ActiveSheet.PasteSpecial (3)
ActiveSheet.PasteSpecial (-4122)

mais cela ne fonctionne pas

Pour vous faciliter la vie, je vous retourne le fichier avec vos codes.
Vos macros sont dans le module "fichiers_distincts".
L'un se nomme "fichierDistinctParFamilleOnglet_Sousou" et l'autre "fichierDistinctParFamilleOnglet_PierreJean"


Merci beaucoup !

 

[pierrejean]

Re

Vois si cette version va mieux

 

[pierrejean]

Re
Vois si cela va mieux

 

[Caroline ;-))]

Merci beaucoup pierrejean.
Bonne journée.