Microsoft 365 Recherchev en VBA ?

akira21

XLDnaute Junior
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 :)
 

Pièces jointes

  • test.xlsx
    39.1 KB · Affichages: 11

sylvanu

XLDnaute Barbatruc
Supporter XLD
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 ? )
 

Pièces jointes

  • Akira.xlsm
    71.4 KB · Affichages: 2

akira21

XLDnaute Junior
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 ? )

Bonsoir Sylvanu,

Merci pour ton aide :)

Effectivement, c'est normal car il peut y avoir le même article mais plusieurs lots.
Donc il faut bien tout prendre et non le 1er.

Encore un grand merci pour ton aide :)
 

akira21

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

Je ne peux pas, il faut vraiment récupérer les lignes telles qu'elle car à la place de test dans les cellules, j'ai d'autres infos qui ne sont pas identiques même si c'est le même code ou lot.
Trop de facteur à prendre en compte.
En gros, une ligne = une palette, chaque palette à son SSCC, son blocage qualité ou non, etc...
Toutes ses infos sont normalement à la place des "test" dans les cellules.
J'ai juste transmis dans le fichier, la mise en forme de l'extract stock car je ne peux pas transmettre les données :/
 

Jacky67

XLDnaute Barbatruc
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 :)
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
 

Pièces jointes

  • testAKIRA.xlsm
    44.8 KB · Affichages: 5
Dernière édition:

akira21

XLDnaute Junior
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

Bonsoir Jacky67,

Merci, c'est exactement ce que je cherchais :)

Encore un grand merci pour ton aide :D

Bonne soirée
 
Haut Bas