Microsoft 365 Recherchev en VBA ?

sylvanu à dit:

Bonjour Akira,
Un essai en PJ avec :

VB:

Sub Recherche()
Sheets("Stock STV").Range("A5:T10000").ClearContents
Application.ScreenUpdating = False
tablo = Sheets("Extract Stock").Cells(4, "A").CurrentRegion
TBDD = Sheets("BDD").Range("A1").CurrentRegion
Lstock = 5
For i = 2 To UBound(TBDD)
    On Error Resume Next
    Ligne = Application.Match(TBDD(i, 1), [CodeArt], 0)
    If Not IsError(Ligne) Then
        Ligne = Ligne - 3
        For Col = 1 To 20
            Sheets("Stock STV").Cells(Lstock, Col) = tablo(Ligne, Col)
        Next Col
        Lstock = Lstock + 1
    End If
Next i
End Sub

Par contre je n'ai pas compris, j'ai plusieurs lignes avec le même code article dans Extract Stock, donc dans la macro je ne prends que le premier. ( ou est ce normal car il y a plusieurs articles en stock ? )

Cliquez pour agrandir...

sylvanu à dit:

Dans ce cas, pourquoi ne pas mettre la quantité ?

Cliquez pour agrandir...

akira21 à dit:

Bonjour,

Je recherche la possibilité de copier le tableau qui est dans la feuille Extract Stock vers la feuille Extract STV mais que les lignes dont les codes sont dans la feuille BDD ?

Pouvez vous m'aider svp ?

Merci à vous

Cliquez pour agrandir...

Sub extractionJJ()
    Dim C As Range, Plage, Lig&
    Feuil5.Range("a5:t" & Rows.Count).Clear
    Application.ScreenUpdating = False
    Set Plage = Feuil4.Range("A4").CurrentRegion
    For Each C In Feuil6.Range("a2:a" & Feuil6.Cells(Feuil6.Rows.Count, "A").End(xlUp).Row)
        Plage.AutoFilter Field:=4, Criteria1:=C
        If Application.Subtotal(103, Plage.Columns("d")) > 1 Then
            Lig = Feuil5.Cells(Feuil5.Rows.Count, "D").End(xlUp).Row + 1
            Plage.Offset(1).Resize(Plage.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Feuil5.Cells(Lig, 1)
        End If
    Next
    Plage.AutoFilter Field:=4
End Sub

Jacky67 à dit:

Bonjour à tous
Une proposition avec ce code

VB:

Sub extractionJJ()
    Dim C As Range, Plage, Lig&
    Feuil5.Range("a5:t" & Rows.Count).Clear
    Application.ScreenUpdating = False
    Set Plage = Feuil4.Range("A4").CurrentRegion
    For Each C In Feuil6.Range("a2:a" & Feuil6.Cells(Feuil6.Rows.Count, "A").End(xlUp).Row)
        Plage.AutoFilter Field:=4, Criteria1:=C
        If Application.Subtotal(103, Plage.Columns("d")) > 1 Then
            Lig = Feuil5.Cells(Feuil5.Rows.Count, "D").End(xlUp).Row + 1
            Plage.Offset(1).Resize(Plage.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Feuil5.Cells(Lig, 1)
        End If
    Next
    Plage.AutoFilter Field:=4
End Sub

Cliquez pour agrandir...