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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
| 'Renvoie l'index de la ligne correspondante au nom donné, dans la feuille donnée, à la colonne donnée
Public Function IndexLigne(ByVal Nom As String, ByVal Feuille As Worksheet, ByVal indCol As Integer) As Integer
Dim rngZoneSearch As Range, varMatch As Variant
Set rngZoneSearch = Intersect(Feuille.Columns(indCol), Feuille.UsedRange)
On Error Resume Next
varMatch = Application.WorksheetFunction.Match(Nom, rngZoneSearch, 0)
If Err.Number <> 0 Then
IndexLigne = -1: Exit Function ' Not found
End If
On Error GoTo 0
IndexLigne = CInt(varMatch)
' Debug.Print "IndexLigne / Nom : " & Nom & " / Feuille : " & Feuille.Name & " / Colonne : " & indCol & " / Trouvé : " & IndexLigne
End Function
Public Function IndexLigneNoInter(ByVal Nom As String, ByVal Feuille As Worksheet, ByVal indCol As Integer, ByVal nbrCmd As Long) As Integer
Dim rngZoneSearch As Range, varMatch As Variant
'Set rngZoneSearch = Intersect(Feuille.Columns(indCol), Feuille.UsedRange)
With Feuille
Set rngZoneSearch = .Range(.Cells(rowNumCmdStart, indCol), .Cells(nbrCmd + rowNumCmdStart - 1, indCol))
End With
On Error Resume Next
varMatch = Application.WorksheetFunction.Match(Nom, rngZoneSearch, 0)
If Err.Number <> 0 Then
IndexLigneNoInter = -1: Exit Function ' Not found
End If
On Error GoTo 0
IndexLigneNoInter = varMatch
End Function
Public Function IndexLigneRangeFind(ByVal Nom As String, ByVal Feuille As Worksheet, ByVal indCol As Integer, ByVal nbrCmd As Long) As Integer
Dim rngZoneSearch As Range, rngFound As Range
With Feuille
Set rngZoneSearch = .Range(.Cells(rowNumCmdStart, indCol), .Cells(nbrCmd + rowNumCmdStart - 1, indCol))
End With
Set rngFound = rngZoneSearch.Find(Nom)
If rngFound Is Nothing Then
IndexLigneRangeFind = -1 ' Not found
Else
IndexLigneRangeFind = rngFound.Row
End If
End Function
Public Function IndexLigneCollection(ByVal Nom As String, ByVal collCol As Collection) As Integer
Dim rngZoneSearch As Range, rngFound As Range
On Error Resume Next
IndexLigneCollection = collCol(Nom)
If Err.Number <> 0 Then
IndexLigneCollection = -1 ' Not found
End If
On Error GoTo 0
End Function
Public Function IndexLigneByNum(ByVal numCmd As Long, ByVal Feuille As Worksheet, ByVal indCol As Integer) As Integer
Dim rngZoneSearch As Range, varMatch As Variant
Set rngZoneSearch = Intersect(Feuille.Columns(indCol), Feuille.UsedRange)
On Error Resume Next
varMatch = Application.WorksheetFunction.Match(numCmd, rngZoneSearch, 0)
If Err.Number <> 0 Then
IndexLigneByNum = -1: Exit Function ' Not found
End If
On Error GoTo 0
IndexLigneByNum = CInt(varMatch)
End Function
Public Function IndexLigneByNumNoInter(ByVal numCmd As Long, ByVal Feuille As Worksheet, ByVal indCol As Integer, ByVal nbrCmd As Long) As Integer
Dim rngZoneSearch As Range, varMatch As Variant
With Feuille
Set rngZoneSearch = .Range(.Cells(rowNumCmdStart, indCol), .Cells(nbrCmd + rowNumCmdStart - 1, indCol))
End With
On Error Resume Next
varMatch = Application.WorksheetFunction.Match(numCmd, rngZoneSearch, 0)
If Err.Number <> 0 Then
IndexLigneByNumNoInter = -1: Exit Function ' Not found
End If
On Error GoTo 0
IndexLigneByNumNoInter = CInt(varMatch)
End Function
Sub PerfIndexLigneStr()
Dim tStart As Double, tEnd As Double, indRow As Long, nbrCmd As Long
Dim nbrMatch As Long, nbrClone As Long, strKey As String, lngKey As Long, indNumCmd As Long
Dim collCol(colNumCmdAutoCont To colNumCmdAutoSurv) As Collection
Application.EnableEvents = False
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
tStart = Time: nbrMatch = 0
For indRow = rowNumCmdStart To rowNumCmdEnd
strKey = Cells(indRow, colNumCmdAutoSurv)
indNumCmd = IndexLigne(strKey, ActiveSheet, colNumCmdAutoSurv)
If indNumCmd > 0 Then nbrMatch = nbrMatch + 1
Next
tEnd = Time
Debug.Print Format(tEnd - tStart, "HH:MM:SS") & " match string: " & nbrMatch & " With intersect"
tStart = Time: nbrMatch = 0
nbrCmd = 27000 ' NbCommandes = ListeCommandesDPN.Rows.Count
For indRow = rowNumCmdStart To rowNumCmdEnd
strKey = Cells(indRow, colNumCmdAutoSurv)
indNumCmd = IndexLigneNoInter(strKey, ActiveSheet, colNumCmdAutoSurv, nbrCmd)
If indNumCmd > 0 Then nbrMatch = nbrMatch + 1
Next
tEnd = Time
Debug.Print Format(tEnd - tStart, "HH:MM:SS") & " match string: " & nbrMatch & " No intersect"
tStart = Time: nbrMatch = 0
nbrCmd = 27000 ' NbCommandes = ListeCommandesDPN.Rows.Count
For indRow = rowNumCmdStart To rowNumCmdEnd
strKey = Cells(indRow, colNumCmdAutoSurv)
indNumCmd = IndexLigneRangeFind(strKey, ActiveSheet, colNumCmdAutoSurv, nbrCmd)
If indNumCmd > 0 Then nbrMatch = nbrMatch + 1
Next
tEnd = Time
Debug.Print Format(tEnd - tStart, "HH:MM:SS") & " match string: " & nbrMatch & " Range Find"
tStart = Time: nbrMatch = 0
Set collCol(colNumCmdAutoSurv) = New Collection
For indRow = rowNumCmdStart To rowNumCmdEnd
strKey = Cells(indRow, colNumCmdAutoSurv)
On Error Resume Next ' Ignorer les doublons du générateur aléatoire de noms
collCol(colNumCmdAutoSurv).Add indRow, key:=strKey
On Error GoTo 0
Next
For indRow = rowNumCmdStart To rowNumCmdEnd
strKey = Cells(indRow, colNumCmdAutoSurv)
indNumCmd = IndexLigneCollection(strKey, collCol(colNumCmdAutoSurv))
If indNumCmd > 0 Then nbrMatch = nbrMatch + 1
Next
While collCol(colNumCmdAutoSurv).Count > 0 ' Clean the collection
collCol(colNumCmdAutoSurv).Remove 1 ' Remove the first item
Wend
Set collCol(colNumCmdAutoSurv) = Nothing
tEnd = Time
Debug.Print Format(tEnd - tStart, "HH:MM:SS") & " match string: " & nbrMatch & " Collection"
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Sub PerfIndexLigneNbr()
Dim tStart As Double, tEnd As Double, indRow As Long, nbrCmd As Long
Dim nbrMatch As Long, nbrClone As Long, strKey As String, lngKey As Long, indNumCmd As Long
Application.EnableEvents = False
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
tStart = Time: nbrMatch = 0
For indRow = rowNumCmdStart To rowNumCmdEnd
lngKey = Cells(indRow, colNumCmdAutoCont)
indNumCmd = IndexLigneByNum(lngKey, ActiveSheet, colNumCmdAutoCont)
If indNumCmd > 0 Then nbrMatch = nbrMatch + 1
Next
tEnd = Time
Debug.Print Format(tEnd - tStart, "HH:MM:SS") & " match nbr: " & nbrMatch & " With intersect"
tStart = Time: nbrMatch = 0
nbrCmd = 27000 ' NbCommandes = ListeCommandesDPN.Rows.Count
For indRow = rowNumCmdStart To rowNumCmdEnd
lngKey = Cells(indRow, colNumCmdAutoCont)
indNumCmd = IndexLigneByNumNoInter(lngKey, ActiveSheet, colNumCmdAutoCont, nbrCmd)
If indNumCmd > 0 Then nbrMatch = nbrMatch + 1
Next
tEnd = Time
Debug.Print Format(tEnd - tStart, "HH:MM:SS") & " match nbr: " & nbrMatch & " No intersect"
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub |
