Spliter classeur en plusieurs onglets
Bonjour à toutes et tous,
Pour le classeur exemple ci dessous je sollicite votre aide pour :
1 créer un onglet de classeur différent dés qu’il y’a une ligne vierge; le nom de l’onglet étant la ligne de la ville isolée par ce "splitage".
Ainsi on aurait : 5 onglets : AMIENS, DIJON CENTRE, NANCY, POISSONNIERE et ROUEN
2 enregistrer chaque onglet dans un classeur différent portant le nom de l’onglet.
Je n’ai pas réussi à adapter les divers sujets du forum qui reprenaient peu ou prou les mêmes thématiques que ma problématique
Merci
Très Cordialement
Hugues
bonjour
Je te propose une solution ci-dessous, à placer dans un module standard
Option Explicit
Sub Extraction()
Dim Ws As Worksheet, Ws2 As Worksheet
Dim ColStart As String, ColEnd As String, MSG As String
Dim PremLig As Long, DernLig As Long
Dim Plage() As Variant, TBL() As String
Dim DICO As Object
Dim VAL As Variant
Dim i As Long, j As Long, cpt As Long
Dim FeuilleExist As Boolean
Set Ws = ThisWorkbook.Worksheets("TEST ONGLET")
ColStart = "A": ColEnd = "B"
PremLig = 2
DernLig = Ws.Range(ColStart & Ws.Rows.Count).End(xlUp).Row
Plage = Ws.Range(ColStart & PremLig & ":" & ColEnd & DernLig)
Set DICO = CreateObject("Scripting.Dictionary")
For i = LBound(Plage) To UBound(Plage)
If Plage(i, 2) <> "" Then DICO(Plage(i, 2)) = ""
Next i
For Each VAL In DICO.Keys
cpt = 0
Erase TBL
For i = 1 To UBound(Plage)
If Plage(i, 2) = VAL Then
cpt = cpt + 1
ReDim Preserve TBL(1 To 2, 1 To cpt)
TBL(1, cpt) = VAL
TBL(2, cpt) = CStr(Plage(i, 1))
End If
Next i
FeuilleExist = False
For j = 1 To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(j).Name = VAL Then FeuilleExist = True: Exit For
Next j
If FeuilleExist = True Then
MSG = MsgBox("La feuille " & VAL & " existe déjàs, si vous poursuivez les données existantes vont-être écrasées. Continuer ?", vbExclamation + vbYesNoCancel)
If MSG = vbYes Then
Set Ws2 = ThisWorkbook.Worksheets(CStr(VAL))
Ws2.Cells.Clear
Ws2.Range("A1").Resize(UBound(TBL, 2), UBound(TBL, 1)) = Application.WorksheetFunction.Transpose(TBL)
End If
Else
Set Ws2 = ThisWorkbook.Worksheets.Add
Ws2.Name = VAL
Ws2.Range("A1").Resize(UBound(TBL, 2), UBound(TBL, 1)) = Application.WorksheetFunction.Transpose(TBL)
End If
Next VAL
End SubOups je viens de me rendre compte que j'ai oublié la partie enregistrement du code
A noter que mon code précédent fonctionne même si les lignes sont mélangées et qu'il n'y a pas de "splittage" avec les lignes vides
Est ce que tu veux avoir une alerte si l'onglet ou le fichier (par exemple AMIEN) existe déjà ou tu ne veux pas d'alerte et écraser par défaut l'onglet et le fichier ?
Voilà ma solution :
pense à adapter cette ligne If NewChemin = False Then Chemin = "C:\Users\lemar\Documents\" 'A ajuster C'est le lien de là où se trouve le dossier de reception pour l'extraction.
Option Explicit
Sub Extraction()
Dim Wb As Workbook
Dim Ws As Worksheet, Ws2 As Worksheet
Dim ColStart As String, ColEnd As String, MSG As String
Dim PremLig As Long, DernLig As Long
Dim Plage() As Variant, TBL() As String
Dim DICO As Object
Dim VAL As Variant
Dim i As Long, j As Long, cpt As Long
Dim FeuilleExist As Boolean
Dim Chemin As String, NomFichier As String
Dim VerifChemin As Boolean, VerifFichier As Boolean, NewChemin As Boolean
Set Ws = ThisWorkbook.Worksheets("TEST ONGLET")
ColStart = "A": ColEnd = "B"
PremLig = 2
DernLig = Ws.Range(ColStart & Ws.Rows.Count).End(xlUp).Row
Plage = Ws.Range(ColStart & PremLig & ":" & ColEnd & DernLig)
Set DICO = CreateObject("Scripting.Dictionary")
For i = LBound(Plage) To UBound(Plage)
If Plage(i, 2) <> "" Then DICO(Plage(i, 2)) = ""
Next i
VerifChemin = True
NewChemin = False
Application.ScreenUpdating = False
For Each VAL In DICO.Keys
cpt = 0
Erase TBL
'//CREATION D'UN TABLEAU VIRTUEL POUR STOCKE DE MANIERE TEMPORAIRE LES DATAS///////////////////////////////
For i = 1 To UBound(Plage)
If Plage(i, 2) = VAL Then
cpt = cpt + 1
ReDim Preserve TBL(1 To 2, 1 To cpt)
TBL(1, cpt) = VAL
TBL(2, cpt) = CStr(Plage(i, 1))
End If
Next i
'//////////////////////////////////////////////////////////////////////////////////////////////////////////
'//TEST SI FEUILLE EXISTE DANS CLASSEUR////////////////////////////////////////////////////////////////////
FeuilleExist = False
For j = 1 To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(j).Name = VAL Then FeuilleExist = True: Exit For
Next j
Set Ws2 = Nothing
If FeuilleExist = True Then
Set Ws2 = ThisWorkbook.Worksheets(CStr(VAL))
Ws2.Cells.Clear
Ws2.Range("A1").Resize(UBound(TBL, 2), UBound(TBL, 1)) = Application.WorksheetFunction.Transpose(TBL)
Else
Set Ws2 = ThisWorkbook.Worksheets.Add
Ws2.Name = VAL
Ws2.Range("A1").Resize(UBound(TBL, 2), UBound(TBL, 1)) = Application.WorksheetFunction.Transpose(TBL)
End If
'//////////////////////////////////////////////////////////////////////////////////////////////////////////
If NewChemin = False Then Chemin = "C:\Users\lemar\Documents\" 'A ajuster
NomFichier = VAL & ".xlsx"
'//CONTROLE QUE LE REPERTOIRE EXISTE///////////////////////////////////////////////////////////////////////
If Dir(Chemin, vbDirectory) <> vbNullString Then VerifChemin = True Else VerifChemin = False
If VerifChemin = False Then
MSG = MsgBox("Le dossier de destination n'existe pas, voulez vous en sélectionner un nouveau ?" & Chr(10) & _
"Pensez à mettre à jour le lien dans le code VBA", vbInformation + vbYesNoCancel)
If MSG = vbYes Then
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count > 0 Then
Chemin = .SelectedItems(1) & "\"
NewChemin = True
Else
MsgBox "Aucun répertoire sélectionné, fin de l'execution", vbCritical
Exit Sub
End If
End With
Else
MsgBox "Aucun répertoire sélectionné, fin de l'execution", vbCritical
End If
End If
'//////////////////////////////////////////////////////////////////////////////////////////////////////////
'//TEST SI LE CLASSEUR EXCEL EXISTE DEJA///////////////////////////////////////////////////////////////////
If Dir(Chemin & NomFichier, vbDirectory) <> vbNullString Then VerifFichier = True Else VerifFichier = False
If VerifFichier = True Then
Set Wb = Application.Workbooks.Open(Chemin & NomFichier)
FeuilleExist = False
For i = 1 To Wb.Worksheets.Count
If Wb.Worksheets(i).Name = VAL Then FeuilleExist = True: Exit For
Next i
If FeuilleExist = True Then
Set Ws2 = Wb.Worksheets(CStr(VAL))
Ws2.Cells.Clear
Else
Set Ws2 = Wb.Worksheets.Add
Ws2.Name = CStr(VAL)
End If
Ws2.Range("A1").Resize(UBound(TBL, 2), UBound(TBL, 1)) = Application.WorksheetFunction.Transpose(TBL)
Wb.Save
Wb.Close
Else
Set Wb = Application.Workbooks.Add
Application.DisplayAlerts = False
For i = Wb.Worksheets.Count To 2 Step -1
Wb.Worksheets(i).Delete
Next i
Application.DisplayAlerts = True
Wb.Worksheets(1).Name = VAL
Wb.Worksheets(1).Range("A1").Resize(UBound(TBL, 2), UBound(TBL, 1)) = Application.WorksheetFunction.Transpose(TBL)
Wb.SaveAs Chemin & NomFichier
Wb.Close
End If
'//////////////////////////////////////////////////////////////////////////////////////////////////////////
Next VAL
Application.ScreenUpdating = True
MsgBox "Extraction terminée", vbInformation
End SubBonjour GGAUTIER,
Je te remercie vivement.
Je teste sur ma base réelle ce jour et te tiens a courant
Mais d'ores et déjà de nouveau merci pour ce code très complet.
Très Cordialement
Hugues
Ca marche
Je viens de voir que tu es sur MAC, j'espère que tu ne vas pas avoir de problèmes
GGAUTIER,
Si sur OFFICE 365 MAC cela va poser des problèmes pour les chemin, l'enregistrement et dictionnaire.
Mais j'ai aussi une machine virtuelle WINDOWS quand le code est trop compliqué a adapter.
Merci
Tu devrais créer un nouveau poste pour demander de l'aide à la communauté afin qu'elle t'aide à convertir mon code pour qu'il puisse fonctionner sur MAC car là c'est en dehors de mes compétences
Bonjour Gautier,
Merci pour ton code je l'ai adapté et il fonctionne en mode windows.
Encore merci pour ton aide
Trés cordialement
Hugues