Sub diviserTableauFeuille()
Dim pTableau As Range
Set pTableau = activeCell.CurrentRegion
Dim ListeValeurs As String
Dim c As Range
For Each c In Intersect(pTableau, activeCell.EntireColumn).Offset(1, 0)
If InStr(1, ListeValeurs, c) = 0 Then
ListeValeurs = ListeValeurs & c & ";"
End If
Next
Dim positionChamp As Integer
positionChamp = activeCell.Column - pTableau.Column + 1
Dim valeur As Variant
For Each valeur In Split(ListeValeurs, ";")
If valeur <> "" Then
Dim feuille As Worksheet
Set feuille = Sheets.Add(after:=Sheets(Sheets.Count))
feuille.Name = valeur
pTableau.AutoFilter Field:=positionChamp, Criteria1:=valeur
pTableau.SpecialCells(xlCellTypeVisible).Copy
feuille.[A1].PasteSpecial xlPasteColumnWidths
feuille.[A1].PasteSpecial xlPasteAll
pTableau.AutoFilter
End If
Next
End Sub
Sub DIVISER_Table_Classeurs()
Dim ws As Worksheet
Dim rng As Range
Dim filterColumn As Range
Dim uniqueValues As Variant
Dim cell As Range
Dim newWorkbook As Workbook
Dim destSheet As Worksheet
Dim lastRow As Long
Dim i As Long
Dim dict As Object
Dim key As Variant
Dim filteredRange As Range
' Déterminer la colonne sur laquelle filtrer en fonction de la cellule active
Set filterColumn = activeCell.EntireColumn
' Assumer que les données commencent dans la feuille active à partir de la
cellule A1
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, filterColumn.Column).End(xlUp).Row
Set rng = ws.Range("A1:X" & lastRow) ' Ajuster la plage en fonction de votre
structure de données
' Vérifier que la colonne est dans la plage de données
If Intersect(filterColumn, rng) Is Nothing Then
MsgBox "La colonne active n'est pas dans la plage de données."
Exit Sub
End If
' Filtrer les données pour les valeurs uniques de la colonne active
filterColumn.Cells(activeCell.Column).AutoFilter Field:=filterColumn.Column,
Criteria1:="<>"
' Récupérer les valeurs uniques filtrées à l'aide d'un dictionnaire
Set dict = CreateObject("Scripting.Dictionary")
On Error Resume Next
Set filteredRange =
ws.AutoFilter.Range.Offset(activeCell.Column).Resize(ws.AutoFilter.Range.Rows.Count
- 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If filteredRange Is Nothing Then
MsgBox "Aucune valeur unique trouvée dans la colonne active après
filtrage."
ws.AutoFilterMode = False
Exit Sub
End If
' Parcourir les cellules visibles et ajouter les valeurs uniques au
dictionnaire
For Each cell In filteredRange.Columns(activeCell.Column).Cells
If Not dict.exists(cell.Value) Then
dict.Add cell.Value, Nothing
End If
Next cell
' Vérifier si des valeurs uniques ont été trouvées
If dict.Count = 0 Then
MsgBox "Aucune valeur unique trouvée dans la colonne active après
filtrage."
ws.AutoFilterMode = False
Exit Sub
End If
' Pour chaque valeur unique, créer un nouveau classeur Excel et copier les
données filtrées
For Each key In dict.keys
' Appliquer le filtre pour la valeur unique actuelle
rng.AutoFilter Field:=filterColumn.Column, Criteria1:=key
' Copier les données filtrées vers une nouvelle feuille temporaire
ws.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
' Créer un nouveau classeur Excel et coller les données
Set newWorkbook = Workbooks.Add
Set destSheet = newWorkbook.Sheets(1)
' destSheet.Name = key
destSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
destSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
' Enregistrer le classeur Excel avec le nom correspondant à la valeur
unique
On Error Resume Next
newWorkbook.SaveAs "C:\Users\y.salam\Desktop\testVBA\TEST VBA\" & key &
".xlsx"
On Error GoTo 0
' Fermer le classeur sans enregistrement des changements visibles
newWorkbook.Close SaveChanges:=False
Next key
' Effacer le filtre dans la feuille principale
ws.AutoFilterMode = False
MsgBox "Extraction des données terminée. Les fichiers ont été enregistrés dans
le dossier : C:\Users\y.salam\Desktop\testVBA\TEST VBA"
'For Each key In dict.keys
' Debug.Print key, dict.Item(key)
' Next key
End Sub
