MACRO VBA- Filtre sur plusieurs quantité

Le 05/08/2022 à 12:14

Bonjour,

J'ai fait une macro qui copie-colle des données de commandes pour in fine imprimer des étiquettes. Cependant je fais fasse à une grosse difficulté.

Suivant la quantité et la nature du matériel je ne souhaite pas copier-coller ces données. Par exemple,

image

Ici j'ai une livraison de 500 Bacs 1000 L Vert spécial verre or, je ne souhaite pas copier-coller cette info, j'aimerais donc créer une règle dans ma macro:

Si matériel contient "1000 L Vert spécial verres" et que quantité supérieur à 6 alors je ne copie-colle pas.

Pareillement, pour l'exemple en dessous:

Si matériel contient "Cartons de saches 400" et que la quantité supérieur à 40 alors je ne copie-colle pas.

Voici, ma macro:

Sub dupliquer_étiquette_effacer_test()

Dim wk_file As Workbook
Dim ws_data As Worksheet
Dim ws_export As Worksheet
Dim lstrw As Long
Dim rw_copy As Long
Dim quantite As Long

'effacer contenu

Sheets(2).Select
Range("A2:H500").ClearContents

'identifier le fichiers et les onglets
Set wk_file = ActiveWorkbook
Set ws_data = wk_file.Worksheets(1)
Set ws_export = wk_file.Worksheets(2)

'identifier la dernière ligne de nos données
lstrw = ws_data.Cells(Rows.Count, 1).End(xlUp).Row

'boucle sur les données
For i = 2 To lstrw
    quantite = ws_data.Cells(i, 4)

    'boucle sur la quantité
    For k = 1 To quantite
        'identifier la ligne de collage
        rw_copy = ws_export.Cells(Rows.Count, 1).End(xlUp).Row + 1

        'coller les infos
        With ws_export
            .Cells(rw_copy, 1) = ws_data.Cells(i, 1)
            .Cells(rw_copy, 2) = ws_data.Cells(i, 2)
            .Cells(rw_copy, 3) = ws_data.Cells(i, 3)
            .Cells(rw_copy, 4) = ws_data.Cells(i, 4)
            .Cells(rw_copy, 5) = ws_data.Cells(i, 5)
            .Cells(rw_copy, 6) = ws_data.Cells(i, 6)
            .Cells(rw_copy, 7) = ws_data.Cells(i, 7)
            .Cells(rw_copy, 8) = ws_data.Cells(i, 8)

        End With

    Next

Next

End Sub

Merci par avance pour votre aide

Le 05/08/2022 à 13:27

Bonjour Elie, bonjour le forum,

Pourquoi pas le fichier qui va bien ?!...

Le 05/08/2022 à 13:42

Salut Thauthème voici le fichier,

merci de ton aide.

14matrice-preparation.xlsm (56.62 Ko)
Le 05/08/2022 à 14:33

Re,

Essaie comme ça :

Sub dupliquer_étiquette_effacer()
Dim ws_data As Worksheet
Dim ws_export As Worksheet
Dim TS As ListObject
Dim lstrw As Long
Dim rw_copy As Long
Dim quantite As Long
Dim M As String

'identifier le fichiers et les onglets
Set ws_data = wk_file.Worksheets(1)
Set TS = ws_data.ListObjects(1)
Set ws_export = wk_file.Worksheets(2)
'effacer contenu de l'onglet ws_export
ws_export Range("A1").CurrentRegion.Offset(1, 0).ClearContents
'boucle sur les données
For I = 1 To TS.ListRows.Count
    M = TS.DataBodyRange(I, 3) 'définit la matériel M
    quantite = TS.DataBodyRange(I, 4)
        Select Case M 'agit en fonction de M
            Case "1000 L Vert spécial verres" 'cas
                If quantité > 6 Then GoTo suite 'si la quantité est supérieure à 6 va à l'étiquette "suite'
            Case "Cartons de saches 400" 'cas
                If quantité > 40 Then GoTo suite 'si la quantité est supérieure à 40 va à l'étiquette "suite'
            Case Else 'tous les autres cas
                'boucle sur la quantité
                For K = 1 To quantite
                    'identifier la ligne de collage
                    rw_copy = ws_export.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    'coller les infos
                    With ws_export
                        For L = 1 To 8 'boucles des colonne 1 à 8
                            'récupère dans la cellule ligne rw-copy, colonne L de l'onglet ws_export, la valeur de la donnée ligne I colonne L de ts
                            .Cells(rw_copy, L).Value = TS.DataBodyRange(I, L).Value
                        Next L
                    End With
                Next K
        End Select
suite: 'étiquette
Next I
End Sub
Le 05/08/2022 à 16:45

Re,

Je te remercie pour ton aide! Malheureusement le message "Erreur d'exécution 424: Object requis" apparait

Le 05/08/2022 à 18:31

Re,

Oui désolé Elie. J'avais pourtant testé mais j'ai dû modifier le code après... Le voici corrigé et testé. J'ai utilisé une variable tableau TV pour accélérer son exécution : 

Sub ThauTheme()
Dim RM As Worksheet 'déclare la variable RM (onglet Réservation Matériel)
Dim FE As Worksheet 'déclare la variable FE (onglet Feuille Étiquettes)
Dim TS As ListObject 'déclare la variable TS (Tableau Structuré)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim Q As Long 'déclare la variable Q (Quantité)
Dim M As String 'déclare la variable M (Matériel)

Set RM = Worksheets(1) 'définit l'onglet RM
Set TS = RM.ListObjects(1) 'définit la tableau structuré TS
TV = TS.DataBodyRange 'définit la tableau des valeurs TV
Set FE = Worksheets(2) 'définit l'onglet FE
FE.Range("A1").CurrentRegion.Offset(1, 0).ClearContents ''efface les anviennes valeurs sauf les en-têtes
For I = 1 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I de TV
    M = TV(I, 3) 'définit la matériel M
    Q = TV(I, 4) 'définit la quantité Q
        Select Case M 'agit en fonction de M
            Case "1000 L Vert spécial verres" 'cas
                If Q > 6 Then 'si la quantité est supérieure à 6
                    GoTo fin 'va à l'étiquette "fin"
                Else 'sinon
                    GoTo suite 'va à l'étiquette "suite"
                End If 'fin de la condition
            Case "Cartons de saches 400 L" 'cas
                If Q > 40 Then 'condition : si la quantité est supérieure à 40
                    GoTo fin 'va à l'étiquette "fin"
                Else 'sinon
                    GoTo suite 'va à l'étiquette "suite"
                End If 'fin de la condition
            Case Else 'tous les autres cas
                GoTo suite
        End Select 'fin de l'action en fonction de M
suite: 'étiquette
    For K = 1 To Q 'boucle 2 : sur le nombre de quantité K
        'identifier la ligne de collage
        DL = FE.Cells(Rows.Count, 1).End(xlUp).Row + 1
        'coller les infos
        FE.Cells(DL, 1).Resize(1, 8).Value = Application.Index(TV, I)
    Next K
fin: 'étiquette
Next I 'prochaine ligne de la boucle 1
MsgBox "Données traitées !" 'message
End Sub
Le 05/08/2022 à 21:09

Hello à tous,

Une autre approche :

Sub dupliquer_étiquette()

    Dim wk_file As Workbook
    Dim ws_data As Worksheet
    Dim ws_export As Worksheet
    Dim lstrw As Long
    Dim rw_copy As Long
    Dim quantite As Long

    'effacer contenu
    Sheets(2).Select
    Range("A2:H50000").ClearContents
    'identifier le fichiers et les onglets
    Set wk_file = ActiveWorkbook
    Set ws_data = wk_file.Worksheets(1)
    Set ws_export = wk_file.Worksheets(2)
    'identifier la dernière ligne de nos données
    lstrw = ws_data.Cells(Rows.Count, 1).End(xlUp).Row
    'boucle sur les données
    For i = 6 To lstrw
        quantite = ws_data.Cells(i, 4)
        strMateriel = ws_data.Cells(i, 3)
        If Not (strMateriel = "1000 L Vert spécial verres" And quantite > 6) _
            And _
        Not (strMateriel = "Cartons de saches 400 L" And quantite > 40) Then
                'boucle sur la quantité
                For k = 1 To quantite
                    'identifier la ligne de collage
                    rw_copy = ws_export.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    'coller les infos
                    With ws_export
                        .Cells(rw_copy, 1) = ws_data.Cells(i, 1)
                        .Cells(rw_copy, 2) = ws_data.Cells(i, 2)
                        .Cells(rw_copy, 3) = ws_data.Cells(i, 3)
                        .Cells(rw_copy, 4) = ws_data.Cells(i, 4)
                        .Cells(rw_copy, 5) = ws_data.Cells(i, 5)
                        .Cells(rw_copy, 6) = ws_data.Cells(i, 6)
                        .Cells(rw_copy, 7) = ws_data.Cells(i, 7)
                        .Cells(rw_copy, 8) = ws_data.Cells(i, 8)
                    End With
                Next
        End If
    Next
    MsgBox "fin"
End Sub
Le 08/08/2022 à 08:39

Merci Rag pour ton aide :)

Merci à toi Thautème ça fonctionne parfaitement! J'ai encore des réglages à faire par rapport aux conditions de la macro mais je vais le faire tout seul car le but est que je sois autonome! :)

Agréable journée à vous.

Rechercher des sujets similaires à "macro vba filtre quantite"