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
| 'Nom de la macro
Sub Extract_data_base()
'Déclaration des vaiables
Dim ref As Integer
Dim cell_ref As Range
Dim rowmax As Integer
Dim cell_sc As Range
Dim off1 As Integer
Dim off2 As Integer
Dim str As String
Dim table() As String
'Affichage d'une inputbox dans laquelle tu rentres la référence que tu veux. Cette référence est un ENTIER !
ref = InputBox("Référence recherchée ?", "Référence", 0)
'Avec la feuille "Data"
With Worksheets("Data")
'On set cell_ref (cellule référence) là où l'on trouve la référence rentrée dans l'inputbox. (On cherche sur la colonne 2)
Set cell_ref = .Columns(2).Find(ref, LookIn:=xlFormulas, lookat:=xlWhole)
'Si on ne trouve pas la référence on affiche une MsgBox et on quitte la macro.
If cell_ref Is Nothing Then
MsgBox "La référence n'a pas été trouvée"
Exit Sub
End If
'On set rowmax à 0.
rowmax = 0
'On boucle 3 fois avec i = 0, 1 puis 2. Cette boucle va nous permettre de tester quelle ligne est la dernière dans la table d'extraction pour ne pas écrire sur des données existantes.
For i = 0 To 2
'On enregistre dans rowmax le numéro de la dernière ligne de la colonne "Columns(1 + (i * 4))", soit la colonne A, E et I du tableau extraction
'SI ET SEULEMENT SI la précédente valeur de rowmax était inférieure
If Worksheets("Export").Columns(1 + (i * 4)).Find("*", , , , xlByColumns, xlPrevious).Offset(1, 0).Row > rowmax Then
rowmax = Worksheets("Export").Columns(1 + (i * 4)).Find("*", , , , xlByColumns, xlPrevious).Offset(1, 0).Row
End If
Next i
'On place donc notre cellule de destination (cell_des) à la bonne ligne (celle qui est complètement vide).
Set cell_des = Worksheets("Export").Cells(rowmax, 1)
'On boucle maintenant 4 fois avec i = 0, 1, 2 puis 3.
For i = 0 To 3
'On place dans la cellule cell_des.Offset(0, i) (c-a-d là où se trouve cell_des avec un offset de i ligne(s) ) ce qui se trouve dans cell_ref.Offset(0, i - 1) (c-a-d là où se trouve cell_des avec un offset de i-1 ligne(s) )
'Cela signifie que dans la feuille export je place les données sur les colonnes A, B, C, D.
cell_des.Offset(0, i) = cell_ref.Offset(0, i - 1)
Next i
'Maintenant on set cell_sc (cellule sous-code) à l'endroit où l'on trouve la référence dans la colonne 4 (soir la D)
Set cell_sc = .Columns(4).Find(ref, LookIn:=xlFormulas, lookat:=xlWhole)
'Si l'on trouve cette référence
If Not cell_sc Is Nothing Then
'On boucle 4 fois et on place les bonnes valeurs de source dans la feuille Export (colonnes E, F, G, H)
For i = 0 To 3
cell_des.Offset(0, i + 4) = cell_sc.Offset(0, i - 3)
Next i
'On redimentionne un tableau (en effacant ses données)
ReDim table(1 To 1)
'On set off1 et off2 à 0
off1 = 0
off2 = 0
'Si il il y a quelque chose dans le sous-code de la ligne de cell_ref alors...
If cell_ref.Offset(0, 2) <> "" Then
'... si on trouve une virgule dans ce sous-code alors...
If InStr(cell_ref.Offset(0, 2), ",") Then
'Je ve vais pas expliquer en détail la suite, c'est complexe.
'Je cherche juste les virgules dans ce sous code et j'enregistre ce qu'il se trouve entre ces virgules (sans l'espace) dans le tableau "table"
off1 = InStr(cell_ref.Offset(0, 2), ",")
table(1) = Left(cell_ref.Offset(0, 2), off1 - 1)
For i = 2 To 100
If InStr(off1 + 1, cell_ref.Offset(0, 2), ",") Then
off2 = InStr(off1 + 1, cell_ref.Offset(0, 2), ",")
ReDim Preserve table(1 To i)
table(i) = Mid(cell_ref.Offset(0, 2), off1 + 2, off2 - off1 - 2)
off1 = off2
Else
ReDim Preserve table(1 To i)
table(i) = Right(cell_ref.Offset(0, 2), Len(cell_ref.Offset(0, 2)) - off1 - 1)
Exit For
End If
Next i
'... et si je ne trouve pas de virgule alors j'enregistre le sous-code entièrement puisqu'il n'y a qu'un seul sous-code
Else
table(1) = cell_ref.Offset(0, 2)
End If
End If
'Ca, c'est des tests perso
' strMessage = ""
' For boucle = 1 To UBound(table)
' strMessage = strMessage & table(boucle) & vbLf
' Next boucle
'
' MsgBox strMessage
'Enfin, je place ce qui se trouve dans mon tableau "table" aux bons endroits dans la feuille Export (c-a-d aux colonnes I, J, K, L)
For i = 0 To UBound(table) - 1
Set cell_sc = .Columns(2).Find(table(i + 1), LookIn:=xlFormulas, lookat:=xlWhole)
For j = 0 To 3
cell_des.Offset(i, j + 8) = cell_sc.Offset(0, j - 1)
Next j
Next i
End If
End With
End Sub |
[VBA] Recherche multiple & Extraction
Répondre avec citation
) 
).
Partager