1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
|
Public Sub EclatementActivité()
Dim maxLine_Onglet_Principal As Long
'A65536
Sheets("Onglet_Principal").Select
maxLine_Onglet_Principal = Range("A1999").End(xlUp).Row
Set RefActivité = Rows(1).Find(what:="Activité")
If RefActivité Is Nothing Then
Exit Sub
Else
RefNumColActivité = Range(RefActivité.Address).Column
RefColActivité = Split(RefActivité.Address, "$")(1)
End If
'Créaton d'un dictionnaire (Récupération des différentes villes)
Set Dico = CreateObject("scripting.dictionary")
For Each Cellule In Sheets("Onglet_Principal").Range(RefColActivité & 2 & ":" & RefColActivité & maxLine_Onglet_Principal)
If Cellule.Value = "" Then
RefKey = "Aucune Activité"
RefItem = Cellule.Value
If Not Dico.exists(RefKey) Then
Dico.Add RefKey, RefItem
End If
Else
ListeActivité = Split(Trim(Cellule.Value), ";")
For i = LBound(ListeActivité) To UBound(ListeActivité)
RefKey = CStr(ListeActivité(i))
RefItem = CStr(ListeActivité(i))
If Not Dico.exists(RefKey) Then
Dico.Add RefKey, RefItem
End If
Next i
End If
Next
'Tri du dictionnaire en mode descending
RefKey = Dico.keys
RefItem = Dico.items
For n = LBound(RefKey) To UBound(RefKey)
For m = LBound(RefKey) To UBound(RefKey)
If RefKey(m) < RefKey(n) Then
TempKey = RefKey(m)
TempItem = RefItem(m)
RefKey(m) = RefKey(n)
RefItem(m) = RefItem(n)
RefKey(n) = TempKey
RefItem(n) = TempItem
End If
Next m
Next n
'Pour chaque Activité, création d'un nouvel onglet et récupération des données
For n = 0 To Dico.Count - 1
Sheets("Onglet_Principal").Select
CritFilter = RefItem(n)
If RefKey(n) = "Aucune Activité" Then
Selection.AutoFilter Field:=RefNumColActivité, Criteria1:=""
ActiveSheet.Cells.SpecialCells(xlCellTypeVisible).Copy
Set New_Sheet = Sheets.Add(Before:=Sheets("Onglet_Principal"))
Else
Selection.AutoFilter Field:=RefNumColActivité, Criteria1:="*" & CritFilter & "*"
ActiveSheet.Cells.SpecialCells(xlCellTypeVisible).Copy
Set New_Sheet = Sheets.Add(Before:=Sheets(1))
End If
New_Sheet.Name = RefKey(n)
ActiveSheet.Paste
Rows(1).AutoFilter
Range("A1").Select
Next n
With Sheets("Onglet_Principal")
If .FilterMode = True Then
.ShowAllData
End If
Range("A1").Select
End With
End Sub |
Partager