Code VBA excel : Copier/coller des données selon critère

Question

Bonjour, 

Je travaille sur une base de données simple (4 colonnes et environ 1000 lignes). Celle-ci comprends plusieurs fois les mêmes références en colonne A. 

Je voudrais pouvoir développer une macro pour que :
Si REF colonne A(feuil1)  apparait 1 fois alors copie colle toute la ligne dans feuil2
Si REF colonne A(feuil1) apparait 2 fois(doublon) alors copie colle toutes les lignes correspondantes dans feuil3
Si REF colonne A(feuil1) apparait 3 fois (triple) alors copie colle toutes les lignes correspondantes dans feuil 4
Si REF colonne A(feuil1) apparait 4 fois alors copie colle toutes les lignes correspondantes dans feuil5
Si REF colonne A(feuil1) apparait 5 fois alors copie colle toutes les lignes correspondantes dans feuil6

Sachant que chaque feuille conserve les mêmes intitulés de colonnes que sur la feuil1

Je ne sais pas trop quel code appliqué : car selon ce que j'ai pu observer c'est un mix de plusieurs cas déjà rencontrés, 

Merci d'avance,

ThauTheme · Answer

Bonsoir ADR, bonsoir le forum,

Essaie comme ça :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
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 DC As Integer 'déclare la variable DC (Dernière Colonne)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim OD As Worksheet 'déclare la variable OD (Onglet de Destinbation)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set O = Worksheets("Feuil1") 'définit l'onglet O
TV = O.Range("A1").CurrentRegion  'définit le tableau des valeurs TV
DL = UBound(TV, 1) 'définit la dernière ligne DL du tableau des valeurs TV
DC = UBound(TV, 2) 'définit la dernière colonne DC du tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To DL 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données ligne I colonne 1 du tableau des valeurs TV
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des données du dictionnaire I sans doublons
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tableau temporaire TMP
    K = 1 'initialise la variable K
    For I = 2 To DL 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 1) = TMP(J) Then 'condition : si la données ligne I colonne 1 de TV est égale à l'élément J du tableau temporaire TMP
            ReDim Preserve TL(1 To DC, 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To DC 'boucle 3 : sur toutes les colonnes de TV (ou toutes les lignes de TL)
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la données en colonne L de TV (=transposition)
            Next L 'prochaine colonne de la boucle (ou prochaine ligne)
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    Select Case K 'agit en fonction de K
        Case 2 'si K vaut 2 (une seule occurrence trouvée)
            Set OD = Worksheets("Feuil2") 'définit l'onglet de destination OD
        Case 3 'si K vaut 3 (deux occurrences trouvées)
            Set OD = Worksheets("Feuil3") 'définit l'onglet de destination OD
        Case 4 'si K vaut 4 (trois occurrences trouvées)
            Set OD = Worksheets("Feuil4") 'définit l'onglet de destination OD
        Case 5 'si K vaut 5 (quatre occurrences trouvées)
            Set OD = Worksheets("Feuil5") 'définit l'onglet de destination OD
        Case 6 'si K vaut 6 (cinq occurrences trouvées)
            Set OD = Worksheets("Feuil6") 'définit l'onglet de destination OD
        Case Else 'tous les autres cas
            Set OD = Worksheets("Feuil7") 'définit l'onglet de destination OD
    End Select 'fin de l'action en fonction de K
    OD.Range("A1").Resize(1, DC).Value = Application.Index(TV, 1) 'copie les intitulés de colonnes dans la ligne 1 de l'onglet OD
    Set DEST = OD.Range("A" & Application.Rows.Count).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
    DEST.Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'revoie dans DEST redimensionnée le tableau TL transposé
    Erase TL 'efface le tableau TL
Next J 'prochain élément de la boucle 1
End Sub

ADR · Answer

Bonjour, 

Merci pour cette réponse complète ! 
Cependant le code ne fonctionne pas au niveau de la ligne 
"Case 3 'si K vaut 3 (deux occurrences trouvées)
Set OD = Worksheets("Feuil3") 'définit l'onglet de destination OD"

ce que je ne comprends pas étant donné que les deux précédents cas fonctionnent très bien, 

Si vous avez une éventuelle idée je suis preneuse, sinon j'essaierais de trouver par moi même :)

ThauTheme · Answer

Bonjour,

Il est évident que les onglets doivent exister avant de lancer la macro car celle-ci ne les crée pas automatiquement (tu ne l'as pas demandé...).
La seule chose qui pourrait faire planter la macro à ce niveau là, c'est que  l'onglet Feuil3 n'existe pas ou qu'il soit orthographié différemment (Feiul3 par exemple).
Tu peux aussi, dans le code, remplacer les noms : "Feuil2", "Feuil3",..., "Feuil7" par leur numéro d'index : 2, 3, ..., 7 pour éviter ce genre de problème de nom différent dans le code et dans le fichier.

Essaie ce nouveau code. Il commence par supprimer tous les onglets sauf le premier puis il ajoute les onglets nécessaires avec pour nom "x fois" et enfin, il les trie par nombre de fois...

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
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 DC As Integer 'déclare la variable DC (Dernière Colonne)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Long 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim OD As Worksheet 'déclare la variable OD (Onglet de Destinbation)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set O = Worksheets("Feuil1") 'définit l'onglet O
Application.DisplayAlerts = False 'désactive les message d'Excel
For I = Sheets.Count To 2 Step -1 'boucle sur tous les onglet (en partant du second)
    Sheets(I).Delete 'supprime l'onglet
Next I 'prochain onglet de la boucle
Application.DisplayAlerts = True 'active les message d'Excel
TV = O.Range("A1").CurrentRegion  'définit le tableau des valeurs TV
DL = UBound(TV, 1) 'définit la dernière ligne DL du tableau des valeurs TV
DC = UBound(TV, 2) 'définit la dernière colonne DC du tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To DL 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données ligne I colonne 1 du tableau des valeurs TV
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des données du dictionnaire I sans doublons
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tableau temporaire TMP
    K = 1 'initialise la variable K
    For I = 2 To DL 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 1) = TMP(J) Then 'condition : si la données ligne I colonne 1 de TV est égale à l'élément J du tableau temporaire TMP
            ReDim Preserve TL(1 To DC, 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To DC 'boucle 3 : sur toutes les colonnes de TV (ou toutes les lignes de TL)
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la données en colonne L de TV (=transposition)
            Next L 'prochaine colonne de la boucle (ou prochaine ligne)
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    On Error Resume Next 'gestio des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Worksheets(K - 1 & " fois") 'définit l'onglet OD
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'efface l'erreur
        Sheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet en dernière position
        ActiveSheet.Name = K - 1 & " fois" 'renomme l'onglet
        Set OD = ActiveSheet 'définit l'onglet OD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OD.Range("A1").Resize(1, DC).Value = Application.Index(TV, 1) 'copie les intitulés de colonnes dans la ligne 1 de l'onglet OD
    Set DEST = OD.Range("A" & Application.Rows.Count).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
    DEST.Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'revoie dans DEST redimensionnée le tableau TL transposé
    Erase TL 'efface le tableau TL
Next J 'prochain élément de la boucle 1
'tri des onglets
For I = 2 To Sheets.Count 'boucle 1 : sur tous les onglets (en partant du second)
    For K = 2 To Sheets.Count 'boucle 2 : sur tous les onglets (en partant du second)
        'si le numéro (avant " fois") de l'onglet I est inférieur au numéro (avant " fois) de l'onglet K, place l'onglet I devant l'onglet K
        If CInt(Split(Sheets(I).Name, " ")(0)) < CInt(Split(Sheets(K).Name, " ")(0)) Then Sheets(I).Move Before:=Sheets(K)
    Next K 'prochain onglet de la boucle 2
Next I 'prochain onglet de la boucle 1
End Sub

Adrx · Answer

Bonjour, 
J'ai de nouveau essayé le premier code qui fonctionne 
Il y a juste une erreur sur la ligne après 
End Select, 
la ligne en erreur est la ligne 
OD.Range ("A1").Resize (1,DC).Value = Application.Index(TV,1)
je ne sais pas d'où vient le soucis donc si quelqu'un pouvait m'aider. 
Ah le message d'erreur qui s'affiche est incompatibilité de type.
Donc si quelqu'un sait me répondre se serait super !
Merci !

Code VBA excel : Copier/coller des données selon critère

4 réponses

Discussions similaires

Newsletters