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
|
Sub AvecTableau()
Dim WB As Workbook
Dim S As Worksheet
Dim R As Range
Dim C As Range
Dim FirstC As String
Dim Miroir As String
Dim Tableau_Registre() '() sans rien = tableau dynamique
Dim cpt& 'compteur
'ouverture fichier Registre
rappro = "C:\test.xlsx"
Workbooks.Open (rappro)
ActiveWorkbook.RunAutoMacros xlAutoOpen
Worksheets("zatox").Activate
'suppression filtres
If Worksheets("zatox").FilterMode Then
Worksheets("zatox").ShowAllData
End If
'### Variables à adapter avec les bons noms ###
Set WB = Workbooks("test.xlsx") 'workbooks("nom_du_classeur")
Set S = WB.Sheets("zatox") 'wb.Sheets("nom_de_la_feuille")
mot = "chat"
'##############################################
Set R = S.Range("L:L")
'--- 1ère occurrence ---
Set C = R.Find(What:=Miroir, After:=[L65536], LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
'If C Is Nothing Then
'MsgBox "aucune occurrence trouvée de : " & mot
'Exit Sub
'End If
FirstC = C.Address
cpt& = cpt& + 1
ReDim Preserve Tableau_Registre(1 To 3, 1 To cpt&) 'seule la dernière dimension peut être redimensionnée
Tableau_Registre(1, cpt&) = C.Offset(0, -11)
Tableau_Registre(2, cpt&) = C.Offset(0, -10)
Tableau_Registre(3, cpt&) = C.Offset(0, -1)
'--- Occurrence(s) suivante(s) ---
Do
Set C = R.FindNext(After:=C)
If C.Address = FirstC Then Exit Do
cpt& = cpt& + 1
ReDim Preserve Tableau_Registre(1 To 3, 1 To cpt&) 'seule la dernière dimension peut être redimensionnée
Tableau_Registre(1, cpt&) = C.Offset(0, -11)
Tableau_Registre(2, cpt&) = C.Offset(0, -10)
Tableau_Registre(3, cpt&) = C.Offset(0, -1)
Loop
'### Pour visualiser le tableau (à virer par la suite) ###
WB.Worksheets("Feuil1").Activate
Set S = ThisWorkbook.Worksheets("Feuil1").Add
Set R = S.Range(Cells(1, 1), Cells(UBound(Tableau_Registre, 2), UBound(Tableau_Registre, 1)))
'on transpose le tableau car dimension1=colonnes et dimension2=lignes
'(voir commentaire plus haut)
R = Application.WorksheetFunction.Transpose(Tableau_Registre)
End Sub |
Partager