XL 2010 VBA boucle pour copier/coller cellules avec condition

[ThomasGLT]

Bonjour à tous,

Étant débutant en VBA et après quelques recherches sur le forum, je viens à demander votre aide concernant la macro suivante (je vais essayer d'être le plus explicite possible) :

Le but de mon fichier (ci-joint pour plus de facilités) est de sortir une feuille d'inventaire pour chaque catégorie (1 / 2 / 3).

Voici les différentes étapes que je souhaiterais que la macro exécute :

• Aller dans "Feuill1" et rechercher à partir de la colonne D le n° de catégorie de l'article
• Suivant le n° de catégorie, copier la référence + le libellé et coller dans "Feuill2" dans le bon tableau
• Puis passer à la ligne suivante jusqu'à que la cellule de la colonne D soit vide
• Si modification des données de la "Feuill1", j'aimerai que toutes les lignes des 3 tableaux de la "Feuill2" reviennent vierges pour mise à jour complète

Voici ce que j'ai réussi seulement à faire et cela ne correspond pas trop à ce que je vous ai défini au dessus... :

Sub test()
'Sélection de la feuille Feull2
Sheets("Feuill2").Select

'Suppression des données tableaux pour mise à jour
Range("B4:D80").Select
ActiveWindow.SmallScroll Down:=-48
Range("B4:D80,G4:I80").Select
Range("G4").Activate
ActiveWindow.SmallScroll Down:=-72
Range("B4:D80,G4:I80,K4:M80").Select
Range("K4").Activate
Selection.ClearContents

'Sélection de la feuille Feull1
Sheets("Feuill1").Select
Range("D2").Select

'Vérification du critère de sélection "1"
Do While ActiveCell.Value <> "" 'Boucle tant qu'on ne tombe pas sur une cellule vide

If ActiveCell.Value = "1" Then

ligne = ActiveCell.Row 'on stocke le numéro de ligne

'copie de la ligne (colonne A à B)
Range(Cells(ligne, 1), Cells(ligne, 2)).Copy
Sheets("Feuill2").Activate
Range("B3").Select

'cas numero 1 : aucune ligne n'a déjà été exportée
If ActiveCell.Offset(1, 0).Value = "" Then
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Feuill1").Select
ActiveCell.Offset(1, 0).Select

'cas numero 2 : des lignes ont déjà été exportées
Else
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Feuill1").Select
ActiveCell.Offset(1, 0).Select

End If

'pas de "1" dans la cellule
Else
ActiveCell.Offset(1, 0).Select
End If
Loop

End Sub

Merci d'avance pour votre aide

Cdt

 

[fanfan38]

Bonjour
Si il y a une modif sur la feuille 1 les données de la feuille 2 sont effacées
J'espère que ça correspond à ce que tu souhaites
A+ François

 

[sylvanu]

Bonjour Thomas, Fanfan,
Un essai en PJ avec :

Sub test()
    Dim DL%, sh, N1%, N2%, N3%
    Application.ScreenUpdating = False
    Sheets("Feuill2").Range("B4:D80,G4:I80,K4:M80").ClearContents   ' Nettoyage de la feuille Feull2
    DL = Range("D65500").End(xlUp).Row                              'Taille tableau
    Set sh = Sheets("Feuill2")
    N1 = 4: N2 = 4: N3 = 4                                          'N1 N2 N3 index écriture des tableaux 1,2,3
    For L = 2 To DL                                                 ' pour toutes les lignes du tableau
        Select Case Cells(L, "D")
            Case 1                                                  ' Cat 1 : écriture dans tableau1
                sh.Cells(N1, "B") = Cells(L, "A")                   ' Ecriture Réference
                sh.Cells(N1, "C") = Cells(L, "B")                   ' Ecriture Libellé
                N1 = N1 + 1                                         ' Incrément index écriture
            Case 2                                                  ' Idem Cat 2
                sh.Cells(N2, "G") = Cells(L, "A")
                sh.Cells(N2, "H") = Cells(L, "B")
                N2 = N2 + 1
            Case 3                                                  ' Idem Cat 3
                sh.Cells(N3, "K") = Cells(L, "A")
                sh.Cells(N3, "L") = Cells(L, "B")
                N3 = N3 + 1
       End Select
    Next L
End Sub

 

[sylvanu]

Re,
et si vous avez beaucoup de lignes, autant passer par un array pour accélérer.
En PJ un essai qui ne prend que 0.18s pour 1000 lignes :

Sub test()
    Dim DL%, sh, N1%, N2%, N3%, T()
    Application.ScreenUpdating = False
    Sheets("Feuill2").Range("B4:D10000,G4:I10000,K4:M10000").ClearContents   ' Nettoyage de la feuille Feull2
    DL = Range("D65500").End(xlUp).Row                              ' Taille tableau
    T = Range("A2:D" & DL)                                          ' Transfert dans array pour être plus rapide
    Set sh = Sheets("Feuill2")
    N1 = 4: N2 = 4: N3 = 4                                          ' N1 N2 N3 index écriture des tableaux 1,2,3
    For L = 1 To UBound(T)                                          ' Pour toutes les lignes du array
        Select Case T(L, 4)
            Case 1                                                  ' Cat 1 : écriture dans tableau1
                sh.Cells(N1, "B") = T(L, 1)                         ' Ecriture Réference
                sh.Cells(N1, "C") = T(L, 2)                         ' Ecriture Libellé
                N1 = N1 + 1                                         ' Incrément index écriture
            Case 2                                                  ' Idem Cat 2
                sh.Cells(N2, "G") = T(L, 1)
                sh.Cells(N2, "H") = T(L, 2)
                N2 = N2 + 1
            Case 3                                                  ' Idem Cat 3
                sh.Cells(N3, "K") = T(L, 1)
                sh.Cells(N3, "L") = T(L, 2)
                N3 = N3 + 1
       End Select
    Next L
End Sub

 

[ThomasGLT]

Bonjour Fanfan38, bonjour sylvanu,

Merci pour vos retours, vos deux solutions me vont parfaitement