Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2010 VBA boucle pour copier/coller cellules avec condition

T

ThomasGLT

XLDnaute Nouveau
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... :

VB: 
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
 

Pièces jointes

  • Fichier test.xlsm
    36.3 KB · Affichages: 30
Solution
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 :
VB: 
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)...
Trier par date Trier par votes

fanfan38

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

Pièces jointes

  • Fichier test.xlsm
    30.4 KB · Affichages: 22
Vote positif 0 Vote négatif

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Thomas, Fanfan,
Un essai en PJ avec :
VB: 
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
 

Pièces jointes

  • Fichier test.xlsm
    34.8 KB · Affichages: 14
Vote positif 0 Vote négatif

sylvanu

XLDnaute Barbatruc
Supporter XLD
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 :
VB: 
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
 

Pièces jointes

  • Fichier test2.xlsm
    297.4 KB · Affichages: 41
Vote positif 0 Vote négatif
Solution
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

M
  • Question
XL 2021 VBA Excel Erreur 2023
Réponses
2
Affichages
184
MICHIS
M
G
  • Question
XL 2019 Sélectionner un fichier pour mettre à jour une base de données
Réponses
3
Affichages
173
sylvanu
G
  • Résolu(e)
Copie de données d'une feuille à une autre
Réponses
2
Affichages
528
gui22
G
H
  • Question
XL 2013 Erreur VBA 1004 Impression zone d'impression tableau
Réponses
13
Affichages
340
Helios77
H
P
  • Question
XL 2016 Compteur avec incrémentation de la ligne suivante
Réponses
11
Affichages
245
Pascal THIDET
P
R
  • Question
XL 2010 Effacement de données dans plusieurs feuilles de calcul dans un même classeur
Réponses
3
Affichages
544
robbynasch
R
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
1 K
job75
Z
  • Question
XL 2016 Macro pour copier plusieurs cellules vers un fichier :(
Réponses
3
Affichages
303
zendb
Z
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
137
patricktoulon
Z
  • Question
Microsoft 365 Ajouter une étiquette de confidentialité via macro
Réponses
4
Affichages
2 K
onobyone
O
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…