Sub extraire_données()
Dim Plage As Range
Dim o As Object
Dim Lastlig As Long
Dim bd As Object
Dim Tb, Res()
Dim Val As String, Val1 As String
Dim dercol As Integer
Dim i As Long
Dim j As Long
'======================================================================
Set bd = Sheets("BD") 'définit l'onglet bd
dl = bd.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit derlg col1 onglet bd
Set o = Sheets("Consult")
Application.ScreenUpdating = False
'==============================================================================
On Error Resume Next
'Dans la variable tableau Tb on récupère toutes les données de la feuille BD
With bd 'Worksheets("BD")
Lastlig = .Cells(.Rows.Count, 1).End(xlUp).Row
Tb = .Range("A2:W" & Lastlig)
End With
With o 'Worksheets("Consult")
dercol = o.Range("A7").End(xlToRight).Column
Val1 = .Range("C1")
Val = .Range("I1")
'on parcours le tableau Tb et si la ligne correspond aux 2 critères
For i = 1 To Lastlig - 1
'
If Tb(i, 3) = Val1 And Tb(i, 18) = Val Then
'on incrémente le compteur j (nombre de lignes trouvées)
j = j + 1
'On redimensionne notre tableau Resultat (12 lignes et j colonnes) Res sera transposé à la fin
'car on ne peut redimenssionner que la dernière dimension
ReDim Preserve Res(1 To 14, 1 To j)
'Le compteur est inscrit en 1ère ligne
Res(1, j) = j
'on fait une petite boucle
Res(2, j) = Tb(i, 1) 'COLONNE A DE BD
Res(3, j) = Tb(i, 4) 'COLONNE D DE BD
Res(4, j) = Tb(i, 19) 'COLONNE S DE BD
Res(5, j) = Tb(i, 23) 'COLONNE W DE BD
''''''''''''''''''''''''
Res(6, j) = Tb(i, 20) 'COLONNE T DE BD
Res(7, j) = Tb(i, 21) 'COLONNE U DE BD
Res(8, j) = Tb(i, 6) 'COLONNE F DE BD
Res(9, j) = Tb(i, 9) 'COLONNE I DE BD
Res(10, j) = Tb(i, 15) 'COLONNE O DE BD
Res(11, j) = Tb(i, 16) 'COLONNE P DE BD
Res(12, j) = Tb(i, 22) 'COLONNE V DE BD
Res(13, j) = Tb(i, 17) 'COLONNE Q DE BD
End If
Next i
'on efface la plage de Calcul
Lastlig = .Cells(.Rows.Count, 1).End(xlUp).Row
If Lastlig > 8 Then .Range("A8:M" & Lastlig).Clear
'on transfère le transposé de Res
If j > 0 Then .Range("A8").Resize(j, 14) = Application.Transpose(Res)
End With
'effectue un tri sur la colonne D. La plage est définie sur la colonne A qui ne comporte pas de vide et
'redimensionnée jusqu'à la colonne M qui elle a des vides
With Worksheets("Consult")
Set Plage = .Range(.Cells(8, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(.Cells(.Rows.Count, 1).End(xlUp), 13)
End With
Plage.Sort Columns(4), xlAscending
Application.ScreenUpdating = True
End Sub
