Création de classeur et copie à partir de valeur unique

Le 14/06/2016 à 10:25

Bonjour à tous

Je dois traiter un fichier de plus de 100 000 lignes contenant les infos suivantes :

Colonne A : Article

Colonne B : Réf. Article

Colonne C : Qté en stock

Colonne D : Réf. PDV

Colonne E : Nom PDV

Une ligne représente une référence dans un point de vente. Il ya donc des doublons, mais c'est normal !

Je souhaiterai, à partir de cette liste, créer pour chacune des référence PDV un nouveau classeur Excel, et y coller l'ensemble des lignes correspondantes à ce PDV. Dans l'exemple que je joins, je souhaiterai donc avec un classeur "1234", dans lequel les lignes 2,3 et 4 seraient collées ; un classeur "1235", avec les lignes 5 et 6, etc.

J'essaye de me débrouiller en VBA, mais j'avoue qu'ici, celà dépasse de loin ma compétence !

Merci d'avance pour votre aide, et n'hésitez pas si vous avez besoin de précisions !

Louis

15exemple.xlsx (8.29 Ko)
Le 14/06/2016 à 12:18

Bonjour Idesevin, bonjour le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

Sub macro1()
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim NC As Byte 'déclare la variable NC (Nombre de Colonnes)
Dim D As Object 'déclare la variable D (Dictionaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim TT As Variant 'déclare la variale TT (Tableau Temporaie)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la varaible K (Onglet Destination)

CH = ThisWorkbook.Path & "\" 'définit le chemin CH
TV = Sheets("Feuil1").Range("A1").CurrentRegion 'définit le tableau de valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To NL 'boucle : sur toutes les lignes I du tableau des valeurs TV
    D(TV(I, 4)) = "" 'alimente le dictionnaire D avec les données de la colonne 4 du tableau ds valeurs TV
Next I 'prochaine ligne de la boucle
TT = D.keys 'récupère dans le tableau temporaire TT la liste des éléments du dictionnaire D sans doublon

For I = 0 To UBound(TT) 'boucle 1 : sur tous les éléments du tableau temporaire TT
    Workbooks.Add 'ajoute un classeur vierge
    Set CD = ActiveWorkbook 'définit le classeur destination CD
    CD.SaveAs (CH & TT(I)) 'enregistre la classeur destination (dans le même dossier que ce classeur) avec comme nom, l'élément TT(I)
    Set OD = CD.Sheets(1) 'définit l'onglet destination (le premier)
    K = 1 'initialise la variable K
    For J = 1 To NL 'boucle 2 : sur toutes les lignes J du tableau des valeurs TV
        If TV(J, 4) = TT(I) Then 'condition : si la donnée ligne J colonne 4 de TV est égale à l'élément TT(I)
            ReDim Preserve TL(1 To NC, 1 To K) 'redimensionne de la tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To NC 'boucle 3 : sur toutes les colonnes L du tableau de valeurs TV
                TL(L, K) = TV(J, L) 'récupère dans la ligne L de TL, la valeur de la colonne L de TV (=transposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
    If K > 1 Then 'condition : si K est supérieure à un (au moins une occurrence trouvée)
        'renvoie dans la cellule A1 de l'onglet OD, le tableau TL transposé
        OD.Range("A1").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
    End If 'fin de la condition
    CD.Close True 'ferme le classeur destination en enregistrant les modification
Next I 'prochaine élément de la boucle 1
End Sub

Le fichier :

17idesevin-v01.xlsm (18.76 Ko)
Le 14/06/2016 à 14:40

Salut ThauThème

Un énooorme merci ! C'est presque bon

J'ai un peu modifié le code que tu m'as donné, et ça fonctionne bien quand je le teste sur le fichier que j'ai joint.

Sub macro1()

Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim NC As Byte 'déclare la variable NC (Nombre de Colonnes)
Dim D As Object 'déclare la variable D (Dictionaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim TT As Variant 'déclare la variale TT (Tableau Temporaie)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la varaible K (Onglet Destination)
Dim CO As Workbook
Dim OO As Worksheet

Set CO = ActiveWorkbook
Set OO = CO.Sheets(1)
TV = Sheets("Feuil1").Range("A1").CurrentRegion 'définit le tableau de valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To NL 'boucle : sur toutes les lignes I du tableau des valeurs TV
    D(TV(I, 4)) = "" 'alimente le dictionnaire D avec les données de la colonne 4 du tableau ds valeurs TV
Next I 'prochaine ligne de la boucle
TT = D.keys 'récupère dans le tableau temporaire TT la liste des éléments du dictionnaire D sans doublon

For I = 0 To UBound(TT) 'boucle 1 : sur tous les éléments du tableau temporaire TT
    Workbooks.Add 'ajoute un classeur vierge
    Set CD = ActiveWorkbook 'définit le classeur destination CD
    Set OD = CD.Sheets(1) 'définit l'onglet destination (le premier)
    K = 1 'initialise la variable K
    For J = 1 To NL 'boucle 2 : sur toutes les lignes J du tableau des valeurs TV
        If TV(J, 4) = TT(I) Then 'condition : si la donnée ligne J colonne 4 de TV est égale à l'élément TT(I)
            ReDim Preserve TL(1 To NC, 1 To K) 'redimensionne de la tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            For L = 1 To NC 'boucle 3 : sur toutes les colonnes L du tableau de valeurs TV
                TL(L, K) = TV(J, L) 'récupère dans la ligne L de TL, la valeur de la colonne L de TV (=transposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
    If K > 1 Then 'condition : si K est supérieure à un (au moins une occurrence trouvée)
        'renvoie dans la cellule A1 de l'onglet OD, le tableau TL transposé
        OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
        OD.Range("H1") = OO.Range("H1")
        OD.Range("I1") = OO.Range("I1")
        OD.Range("J1") = OO.Range("J1")
        OD.Range("K1").FormulaR1C1 = _
        "=RC[-3]&""_""&R[1]C[-7]&""_""&R[1]C[-6]&""_""&RC[-2]&""_""&RC[-1]"
    End If 'fin de la condition

    CH = "K:\Partage_KAM\Stocks Clients WP\Test\" & OD.Range("H1") & "\" 'définit le chemin CH
    If Dir("K:\Partage_KAM\Stocks Clients WP\Test\" & OD.Range("H1").Value, 16) = "" Then MkDir ("K:\Partage_KAM\Stocks Clients WP\Test\" & OD.Range("H1").Value)
    CD.SaveAs (CH & Range("K1").Value)
    CD.Close True 'ferme le classeur destination en enregistrant les modification

Next I 'prochaine élément de la boucle 1
End Sub

En revanche, lorsque je le lance dans le classeur que je dois réellement traiter, VBA me sort une erreur 6 : dépassement de capacité. Une idée ?

Merci !

EDIT : C'est bon ! J'ai changé les déclaration de NL, I et J en Long et tout fonctionne ! Merci mille fois ThauThème !

Rechercher des sujets similaires à "creation classeur copie partir valeur unique"