Macro pour copier des lignes de la feuille principale vers d'autres feuille

Question

Je débute en VBA et j'ai un peu de mal avec les différentes fonctions. Le but est de copier la ligne entière selon le code postal dans la feuille approprié. J'ai ecris la formule voulu sur la feuille 11, j'aimerais pouvoris l'automatisé avec 2 contraintes : - éviter les lignes vides dans les feuilles de destination - Création de la feuille avec le département si inexistante (c'est du bonus, sinon j'en créé 100 à la mano). Dernière petit souhait, si vous m'aider pouvez vous commenter la macro afin que je comprenne pour devenir autonome?^^ (j'en demande peut être un peu beaucoup...) Merci par avance. Bonne soirée...

ThauThème · Accepted Answer

Bonsoir Popo, bonsoir le forum,

Essaie comme ça :

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set OS = Worksheets("Feuil1") 'définit l'onglet OS
TV = OS.Range("A4").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(Left(TV(I, 1), 2)) = "" 'alimente le dictionnaire D avec les deux premiers caractères de la donnée ligne I colonne 1 de TV
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des départements du dictionnaire D sans doublons
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les départements J du tableau temporaire TMP
    K = 0: Erase TL 'initialise K, efface TL
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Worksheets(TMP(J)) 'définit l'onglet destination OD (l'onglet du département), génère une erreur si cet onglet n'existe pas
    If Err > 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Worksheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet vierge en dernière position
        Set OD = ActiveSheet 'définit l'onglet OD
        OD.Name = TMP(J) 'nomme l'onglet OD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OD.Cells.Clear 'efface le contenu de l'onglet OD
    OD.Range("A1").Resize(1, UBound(TV, 2)).Value = Application.Index(TV, 1) 'recopie la ligne d'en-têtes
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If Left(TV(I, 1), 2) = TMP(J) Then 'si les deux premiers caractères de la donnée de la boucle 2 en  colonne 1, correspondent au département J de la boucle 1
            K = K + 1 'incrémente K
            ReDim Preserve TL(1 To 3, 1 To K) 'redimensionne le tableau des lignes TL (3 lignes, K colonnes)
            TL(1, K) = TV(I, 1) 'récupère dans la ligne 1 de TL la donnée en colonne 1 de TV (=> transposition)
            TL(2, K) = TV(I, 2) 'récupère dans la ligne 2 de TL la donnée en colonne 2 de TV (=> transposition)
            TL(3, K) = TV(I, 3) 'récupère dans la ligne 3 de TL la donnée en colonne 3 de TV (=> transposition)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    'si K est supérieure à zéro, renvoie le tableau TL transposé dans A2 redimensionnée de l'onglet OD
    If K > 0 Then OD.Range("A2").Resize(K, UBound(TV, 2)).Value = Application.Transpose(TL)
Next J 'prochain département de la boucle
End Sub

gmb · Accepted Answer

Un essai à tester. Te convient-il ? Bye ...