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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
Option Explicit
Option Compare Text
Dim liste As Range
Sub Crée_Feuilles()
Dim dercel As Range
With Sheets("Recap")
Set dercel = .Cells(.Rows.Count, 5).End(xlUp)
Set liste = .Range(.Cells(4, 5), dercel)
End With
Call Creer_Liste_Feuilles(liste)
Set dercel = Nothing
Set liste = Nothing
End Sub
Sub Creer_Liste_Feuilles(Plage As Range)
Dim Cell As Range
Dim Un As Collection
Dim i As Long, j As Long
Dim Inverse1, Inverse2, Item
Set Un = New Collection
On Error Resume Next
'Boucle sur la plage de cellule
For Each Cell In Plage
'If Cell <> "" Permet de ne pas prendre en compte les cellules vides
'Un.Add Cell, CStr(Cell) Ajoute le contenu de la cellule dans la collection
If Cell <> "" Then Un.Add Cell, CStr(Cell)
Next Cell
On Error GoTo 0
'Trie la collection
For i = 1 To Un.Count - 1
For j = i + 1 To Un.Count
If Un(i) > Un(j) Then
Inverse1 = Un(i)
Inverse2 = Un(j)
Un.Add Inverse1, before:=j
Un.Add Inverse2, before:=i
Un.Remove i + 1
Un.Remove j + 1
End If
Next j
Next i
'Boucle sur les éléments de la collection.
For i = 1 To Un.Count
Debug.Print Un(i)
Call Gestion_Feuilles(Un(i))
Next i
Set Un = Nothing
End Sub
Public Sub Gestion_Feuilles(occurs As String)
Dim i As Integer, n As Integer, nbcol As Integer
Dim f As Range, celcop As Range
Dim firstAddress As String
Dim Tablo() As Variant
Dim sh As Worksheet
Dim existe_feuil As Boolean
With Sheets("Recap")
Set celcop = .Range("E3", .Cells(3, .Columns.Count).End(xlToLeft))
End With
'nombre de données à alimenter = dimension 1 de la variable Tablo
nbcol = celcop.Columns.Count
'Teste si la feuille existe
existe_feuil = False
For Each sh In Worksheets
If sh.Name = occurs Then
existe_feuil = True
Exit For
End If
Next sh
'Si la feuille n'existe pas, alors création de celle-ci avec nom et titres de colonnes adaptés
If existe_feuil = False Then
Sheets.Add Type:=xlWorksheet, After:=Sheets(Sheets.Count)
celcop.Copy
With ActiveSheet
.Paste Destination:=.Range("C3")
.Name = occurs
End With
Application.CutCopyMode = False
End If
'D'après l'aide en ligne de la méthode Find
With liste
Set f = .Find(occurs, LookIn:=xlValues)
If Not f Is Nothing Then
firstAddress = f.Address
Do
n = n + 1
ReDim Preserve Tablo(1 To nbcol, 1 To n)
'Toutes les cellules de la ligne alimentent Tablo
For i = 1 To nbcol
Tablo(i, n) = f.Offset(0, i - 1)
Next i
Set f = .FindNext(f)
Loop While Not f Is Nothing And f.Address <> firstAddress
End If
End With
'Alimentation de la feuille
With Sheets(occurs)
.Range("C3", .Range("C3").Offset(UBound(Tablo, 2) - 1, UBound(Tablo, 1) - 1)).Value = WorksheetFunction.Transpose(Tablo)
End With
'Réinitialisation de la variable Tablo
Erase Tablo
End Sub |
Détection d'une valeur dans un tableau de données variables - VBA
Répondre avec citation
Partager