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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
| Option Explicit
Dim oFSO As FileSystemObject
Dim oFld0 As Folder, oFld1 As Folder, oFld2 As Folder
Dim oFl0 As File, oFl1 As File
Dim oWB0 As Workbook, oWB1 As Workbook
Dim oWS0 As Worksheet, oWS1 As Worksheet
Dim nomBox As String, titreCol0 As String, titreCol1 As String, pathXLFile As String
Dim col0 As Integer, col1 As Integer, lastCol0 As Integer, lastCol1 As Integer, lastLin0 As Integer, lastLin1 As Integer, aftLastLin0 As Integer, aftLastCol0 As Integer, i As Integer
Dim ligneEmplacementDeb As Integer, ligneEmplacementFin As Integer
Dim colTrouvee As Boolean, rangeTrouve As Boolean
Dim rangeToDelete As Range, rangeDest As Range, foundRange As cLocatedRange
Dim racine As MSComctlLib.node
Dim nbreNoeud As Integer
Sub CommandButton1_Click() 'OK
'On Error GoTo Handler1
Application.Cursor = xlWait
Set oFSO = New Scripting.FileSystemObject
Set oFld0 = oFSO.GetFolder("C:\Documents and Settings\mclozel\Desktop\BASE DE DONNEES COMPOSANTS MECANIQUES\MODELES\VISSERIE")
Set oFl0 = oFSO.GetFile("C:\Documents and Settings\mclozel\Desktop\base_visserie1.xls")
Set oWB0 = Workbooks.Open(oFl0)
Set oWS0 = oWB0.Sheets(1)
With Me.TreeView1
Set racine = .SelectedItem.root
nbreNoeud = racine.Child.LastSibling.Child.LastSibling.Index
MsgBox nbreNoeud
For i = 1 To nbreNoeud '<= c'est pour cette boucle que ça coince
If .Nodes(i).Checked Then
If Not .Nodes(i).Text = "VISSERIE" Then
If Not .Nodes(i).Parent.Text = "VISSERIE" Then
'On Error GoTo Handler1
nomBox = NouvNom(.Nodes(i).Text)
MsgBox nomBox
pathXLFile = findXLFilePath(nomBox, oFld0)
Set foundRange = findRange(nomBox, oWS0)
MsgBox foundRange.trouve
'*************************************************************************
'S 'il trouve le type recherché dans base_visserie
If foundRange.trouve = True Then
'On Error GoTo Handler2
'Set rangeToDelete = foundRange.myRange
oWS0.Rows(foundRange.debut & ":" & foundRange.fin).EntireRow.Delete
Set oFl1 = oFSO.GetFile(pathXLFile)
Set oWB1 = Workbooks.Open(oFl1)
Set oWS1 = oWB1.Worksheets(1)
oWS0.Cells(foundRange.debut, 1).EntireRow.Resize(derLigne(oWS1) - 1).Insert
For col1 = 2 To derCol(oWS1)
titreCol1 = NouvNom(oWS1.Cells(1, col1).Value)
Set rangeDest = Nothing
For col0 = 1 To derCol(oWS0)
titreCol0 = UCase(NouvNom(CStr(oWS0.Cells(1, col0).Value)))
colTrouvee = False
If titreCol0 = titreCol1 Then
oWS1.Activate
Application.CutCopyMode = False
oWS0.Range(oWS0.Cells(foundRange.debut, col0), oWS0.Cells(foundRange.fin, col0)).Value = oWS1.Range(Cells(2, col1), Cells(derLigne(oWS1), col1)).Value
colTrouvee = True
Exit For
End If
Next col0
If Not colTrouvee Then
aftLastCol0 = apresDerCol(oWS0)
oWS1.Activate
Application.CutCopyMode = False
oWS1.Range(Cells(2, col1), Cells(derLigne(oWS1), col1)).Select
Selection.Copy
oWS0.Activate
oWS0.Select
Set rangeDest = Evaluate(oWS0.Cells(foundRange.debut, aftLastCol0))
rangeDest.Insert Shift:=xlDown
oWS0.Cells(1, col0) = oWS1.Cells(1, col1)
Application.CutCopyMode = False
End If
Next col1
oWB1.Close False
'*************************************************************************
'S 'il ne trouve pas le type recherché dans base_visserie
Else
Set oWB1 = Workbooks.Open(pathXLFile)
Set oWS1 = oWB1.Worksheets(1)
lastLin0 = derLigne(oWS0)
aftLastLin0 = apresDerLig(oWS0)
MsgBox "***"
lastCol1 = derCol(oWS1)
For col1 = 2 To lastCol1
titreCol1 = NouvNom(CStr(oWS1.Cells(1, col1).Value))
Set rangeDest = Nothing
For col0 = 1 To derCol(oWS0)
titreCol0 = NouvNom(CStr(oWS0.Cells(1, col0).Value))
colTrouvee = False
If titreCol0 = titreCol1 Then
oWS1.Activate
Application.CutCopyMode = False
oWS1.Range(Cells(2, col1), Cells(derLigne(oWS1), col1)).Select
Selection.Copy
oWS0.Activate
oWS0.Select
Set rangeDest = oWS0.Cells(aftLastLin0, col0)
rangeDest.Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
colTrouvee = True
Exit For
End If
Next col0
If Not colTrouvee Then
aftLastCol0 = apresDerCol(oWS0)
oWS1.Activate
Application.CutCopyMode = False
oWS1.Range(Cells(2, col1), Cells(derLigne(oWS1), col1)).Value.Select
Selection.Copy
oWS0.Activate
oWS0.Select
Set rangeDest = oWS0.Cells(aftLastLin0, aftLastCol0)
rangeDest.Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
oWS0.Cells(1, col0) = oWS1.Cells(1, col1)
Application.CutCopyMode = False
End If
Next col1
End If
End If
End If
End If
Next i '<= il ne le fait pas
'MsgBox "Done_1"
End With
'*********************************************************************************
'Mise en forme
oWS0.Range("C2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]&"" ""&RC[1]&"" ""&RC[5]"
oWS0.Range("C2").Select
Selection.AutoFill Destination:=oWS0.Range("C2:C" & derLigne(oWS0))
'MsgBox "Done_2"
Application.Cursor = xlDefault
oWS0.Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
oWS0.Rows("1:1").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
'MsgBox "Done_3"
'For i = 2 To derLigne(oWS0)
'If WorksheetFunction.IsNA(Cells(i, 2)) = True Or oWS0.Cells(i, 2).Value = "" Then Rows(i).EntireRow.Delete
'Next i
Selection.EntireRow.AutoFit ' ajuste la taille de la 1ère ligne
Application.Cursor = xlDefault
Unload Me
Exit Sub
'****************************************************************************
'Error Handling
'Handler1:
' MsgBox "Erreur durant la première partie du programme"
' Application.Cursor = xlDefault
' oWB0.Close False
' Exit Sub
'Handler2:
' MsgBox "Erreur durant la deuxième partie du programme"
' Application.Cursor = xlDefault
' oWB0.Close False
' oWB1.Close False
End Sub
Sub CommandButton2_Click() 'ANNULER
Unload usrFrmMaj
Exit Sub
End Sub
'****************************************************************************************
'Fonctions servant à cocher/décocher les enfants lorsque l'utilisateur coche/décoche les parents, merci Silkyroad
Private Sub TreeView1_NodeCheck(ByVal node As MSComctlLib.node)
CocheDecoche node.Child, node.Children, node.Checked
End Sub
Private Sub CocheDecoche(noeud As MSComctlLib.node, NbEnfants As Integer, boolNd As Boolean)
Dim i As Integer
Dim xNoeud As node
If NbEnfants = 0 Then Exit Sub
Set xNoeud = noeud
For i = 1 To NbEnfants
If xNoeud.Children > 0 Then _
CocheDecoche xNoeud.Child, xNoeud.Children, boolNd
xNoeud.Checked = boolNd
If i < NbEnfants Then Set xNoeud = xNoeud.Next
Next
End Sub
'****************************************************************************************
'désactive la croix rouge du userForm, y'a un bouton "annuler" de toute façon
Public Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
'****************************************************************************************
'renvoit le path du fichier .xls associé à l'élément à mettre à jour ou à ajouter
Function findXLFilePath(name As String, fld0) As String
Dim fld1 As Folder, fld2 As Folder
Dim fl As File
Dim foundFile As Boolean
foundFile = False
Application.Cursor = xlWait
'On Error GoTo findXLFilePathHandler
For Each fld1 In fld0.SubFolders
If (Left(NouvNom(oFSO.GetBaseName(fld1)), 3) = Left(NouvNom(name), 3)) Then
For Each fld2 In fld1.SubFolders
If (Right(NouvNom(oFSO.GetBaseName(fld2)), 3) = Right(NouvNom(name), 3)) Then
For Each fl In fld2.Files
If oFSO.GetExtensionName(fl) Like "*xls" Then
If (Left(NouvNom(oFSO.GetBaseName(fl)), 3) = Left(name, 3)) Then
findXLFilePath = oFSO.GetAbsolutePathName(fl)
foundFile = True
'MsgBox "found XLFilePath"
End If
End If
Next fl
End If
If oFSO.GetBaseName(fld2) = "VIS H ISO 40144017" And foundFile = False And Left(Split(CStr(name), " ", -1)(2), 3) = "401" Then
findXLFilePath = "C:\Documents and Settings\mclozel\Desktop\BASE DE DONNEES COMPOSANTS MECANIQUES\MODELES\VISSERIE\VIS\VIS H ISO 40144017\VIS H ISO 40144017.xls"
foundFile = True
'MsgBox "found XLFilePath"
Exit Function
End If
Next fld2
End If
Next fld1
If foundFile = False Then MsgBox "Excel file corresponding to " & name & " was not found"
Application.Cursor = xlDefault
Exit Function
'findXLFilePathHandler:
'MsgBox "function findXLFilePath could not operate correctly for " & name
End Function
'****************************************************************************************
'donne un range (myRange) contenant les lignes d'un fichier excel correspondant au terme (name) donné en entrée, ainsi que la première ligne (debut) de ce range et la dernière ligne (fin).
Function findRange(name As String, WS As Worksheet) As cLocatedRange
Set findRange = New cLocatedRange
Dim nomFormate As String, tabNom() As String
Dim i As Integer, z As Integer, trouvOcc As Boolean, colTet As Integer
i = 1 'i parcourt les lignes du fichier
trouvOcc = False
Application.Cursor = xlWait
'On Error GoTo findRangeHandler
For colTet = 1 To derCol(WS)
If NouvNom(CStr(WS.Cells(1, colTet).Value)) = "TETON" Then Exit For 'Car les Vis STHC ISO 4028 ont soit un téton long, soit un téton court
Next colTet
'MsgBox colTet
With WS
z = apresDerLig(WS)
While i <= z
nomFormate = NouvNom(CStr(.Range("C" & i).Value))
If Left(nomFormate, 3) = Left(name, 3) Then
If Right(nomFormate, 3) = Right(name, 3) Then
.Rows(i).Select
If trouvOcc = False Then
findRange.debut = i
Set findRange.myRange = Selection
trouvOcc = True
Else: findRange.myRange = Union(findRange.myRange, Selection)
End If
Else 'EXCEPTIONS : QUAND LES NOMS NE SONT PAS IDENTIQUES - essayé avec un Select Case mais me suis mal débrouillée
tabNom = Split(nomFormate, " ", -1)
If Right(nomFormate, 4) = "P 66" Then 'Car la norme dimensionnelle IP 66 n'apparaît pas pour les presse-étoupes ISOCAP dans les noms de dossier, mais dans base-visserie oui, car le nom est composé FAMILLE+TYPE+NORME_DIMENSIONNELLE
tabNom = Split(nomFormate, " ", -1) 'ok
If Right(tabNom(1), 3) = Right(name, 3) Then
'MsgBox "yep66"
.Rows(i).Select
If trouvOcc = False Then
findRange.debut = i
Set findRange.myRange = Selection
trouvOcc = True
Else: findRange.myRange = Union(findRange.myRange, Selection)
End If
Else
If trouvOcc = True Then
findRange.fin = i - 1
GoTo Skip
End If
End If
Else
If UBound(tabNom) >= 3 Then
If tabNom(3) = "4028" Then
'MsgBox Split(name, " ", -1)(5) & " = " & NouvNom(CStr(.Cells(i, colTet).Value)) & " ?"
If Split(name, " ", -1)(5) = "LONG" And NouvNom(CStr(.Cells(i, colTet).Value)) = "LONG" Then
'MsgBox "yep2"
.Rows(i).Select
If trouvOcc = False Then
findRange.debut = i
Set findRange.myRange = Selection
trouvOcc = True
Else: findRange.myRange = Union(findRange.myRange, Selection)
End If
Else
If Split(name, " ", -1)(5) = "COURT" And NouvNom(CStr(.Cells(i, colTet).Value)) = "COURT" Then
.Rows(i).Select
If trouvOcc = False Then
findRange.debut = i
Set findRange.myRange = Selection
trouvOcc = True
Else: findRange.myRange = Union(findRange.myRange, Selection)
End If
Else
If trouvOcc = True Then
findRange.fin = i - 1
GoTo Skip
End If
End If
End If
Else
If trouvOcc = True Then
findRange.fin = i - 1
GoTo Skip
End If
End If
Else
If trouvOcc = True Then
findRange.fin = i - 1
GoTo Skip
End If
End If
End If
End If
Else
If trouvOcc = True Then
findRange.fin = i - 1
GoTo Skip
End If
End If
i = i + 1
Wend
Skip:
findRange.trouve = trouvOcc
'MsgBox findRange.trouve
'MsgBox findRange.debut
'MsgBox findRange.fin
'findRangeHandler:
'MsgBox "function findRange could not operate correctly for " & name
End With
Application.Cursor = xlDefault
End Function
'************************************************************************
'blessed are the wee things
Function NouvNom(name As String) As String 'met un nom sous une forme plus générale: pas de ponctuation, en majuscules
Dim aRemplacer As Variant
Dim tabname() As String
Dim i As Integer
aRemplacer = Array(".", "_", "`", "è", "é", "â", "-", "/", " ")
NouvNom = Trim(name)
NouvNom = Replace(NouvNom, aRemplacer(0), "")
NouvNom = Replace(NouvNom, aRemplacer(1), " ")
NouvNom = Replace(NouvNom, aRemplacer(2), "")
NouvNom = Replace(NouvNom, aRemplacer(3), "e")
NouvNom = Replace(NouvNom, aRemplacer(4), "e")
NouvNom = Replace(NouvNom, aRemplacer(5), "a")
NouvNom = Replace(NouvNom, aRemplacer(6), "")
NouvNom = Replace(NouvNom, aRemplacer(7), "")
NouvNom = Replace(NouvNom, aRemplacer(8), " ")
NouvNom = UCase(NouvNom)
End Function
'*************************************************************************
'Fonctions passe-partout
Function derCol(WS As Worksheet) As Integer 'donne la dernière colonne d'une feuille, lig et col sont toutefois à adapter à la situation
Dim lig As Integer, col As Integer
lig = 1
col = 1
If IsEmpty(WS.Cells(lig, col)) Then
derCol = col
Else
Do Until IsEmpty(WS.Cells(lig, col))
col = col + 1
Loop
derCol = col - 1
End If
End Function
Function derLigne(WS As Worksheet) As Integer 'donne la dernière ligne d'une feuille, la valeur de i est toutefois à adapter à la situation
derLigne = 1
For i = 1 To WS.Columns.Count
If (WS.Cells(Rows.Count, i).end(xlUp).Row) > derLigne Then
derLigne = WS.Cells(Rows.Count, i).end(xlUp).Row
End If
Next i
End Function
'************************************************************************
'Fonctions peu utiles mais ayant tout de même servi
Function apresDerLig(WS As Worksheet) As Integer 'donne l'après dernière ligne d'une feuille
apresDerLig = derLigne(WS) + 1
End Function
Function apresDerCol(WS As Worksheet) As Integer 'donne l'après dernière colonne d'une feuille
apresDerCol = derCol(WS) + 1
End Function |
Sub associé à un checked treeview
Répondre avec citation
Partager