XL 2019 cree des ficher excel d'apres un liste

[Raed22]

bonjour
je veut un programme VBA

prend le ficher source et cree des ficher excel nommer depuis la colone A et nommer les feuille depuis colone B puis copier les valeur corrspond

 

[Robert]

Bonjour Raed, bonjour le forum,

Le code ci-dessous devrait convenir. Les fichier sont crées dans la même dossier que le fichier source...

Sub Macro1()
Dim ONC As Byte 'déclare la variable ONC (Onglets  dans Nouveau Classeur)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D1 As Object 'déclare la variable D1 (Dictionnaire 1)
Dim D2 As Object 'déclare la variable D2 (Dictionnaire 2)
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 L As Integer 'déclare la variable L (incrément)
Dim TMP1 As Variant 'déclare la variable TMP1 (tableau TeMPoraire 1)
Dim TMP2 As Variant 'déclare la variable TMP2 (tableau TeMPoraire 2)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim TVO() As Variant 'déclare la variable TVO (Tableau des Valeurs de l'Onglet)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
ONC = Application.SheetsInNewWorkbook 'récupère dans la variable ONC la valeur par défaut de l'utilisateur du nombre d'onglets dans un nouveau classeur
CA = ThisWorkbook.Path & "\" 'définit le chemin d'accès CA
Set O = Worksheets("Feuil1") 'définit l'onglet O
TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D1 = CreateObject("Scripting.Dictionary") 'définit le dictionnaire 1
For I = 1 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV
    D1(TV(I, 1)) = "" 'alimente le dictionnaire D1 avec les données dans la colonne 1 de TV
Next I 'prochaine ligne de la boucle
TMP1 = D1.Keys 'récupère dans le tableau temporaire TMP1 la liste des éléments de D1 sans doublon (les Clés) (nous savons combien de fichier il faudra créer)
For J = 0 To UBound(TMP1) 'boucle 1 : sur tous les éléments du tableau temporaire TMP1 (les fichiers)
    Set D2 = CreateObject("Scripting.Dictionary") 'définit le dictionnaire 2
    For I = 1 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV
        If TMP1(J) = TV(I, 1) Then D2(TV(I, 2)) = "" 'si l'élément TMP1(J) est égal à la donnée TV(I,1), alimente le dictionnaire D2 avec les données dans la colonne 2 de TV
    Next I 'prochaine ligne de la boucle 2
    TMP2 = D2.Keys 'récupère dans le tableau temporaire TMP2 la liste des éléments de D2 sans doublon (les Clés) (nous savons combien d'onglet aura le fichier de la boucle 1)
    Application.SheetsInNewWorkbook = D2.Count 'définit le nombre d'onglet par défaut dans un nouveau classeur
    Application.Workbooks.Add 'ajoute un classeur vierge
    Set CD = ActiveWorkbook 'définit le classeur destination CD
    CD.SaveAs CA & TMP1(J), 51 'enregistre sous le classeur destination (même chemin d'accès que le fichier d'origine avec comme nom la donnée de la boucle 1 TMP1(J)
    For K = 0 To UBound(TMP2) 'boucle 3 : sur sur tous les éléments du tabeau temporaire TMP2 (les onglets)
        L = 0 'réinitialise la variable L
        CD.Worksheets(K + 1).Name = TMP2(K) 'définit le nom TMP2(K) de l'onglet de la boucle 3
        For I = 1 To UBound(TV, 1) 'boucle 4 : sur toutes les lignes I du tableau des valeurs TV
            If TMP1(J) = TV(I, 1) And TMP2(K) = TV(I, 2) Then 'condition : si le nom du fichier et le nom de l'onglet correspondent
                ReDim Preserve TVO(L) 'redimensionne le tableau TVO
                TVO(L) = TV(I, 3) 'récupère dans TVO(L) la donnée en colonne 3 du tableau des valeur TV
                L = L + 1 'incrémente L
            End If 'fin de la condition
        Next I 'prochaine ligne de la boucle 4
        CD.Worksheets(K + 1).Range("A1").Resize(L, 1).Value = Application.Transpose(TVO) 'renvoie le tableau TVO transposé dans A1 redimensionnée de l'onglet de la boucle 3
    Next K 'prochain onglet de la boucle 3
    CD.Close True 'ferme le classeur destination en enregistrant les modifications
Next J 'prochain fichier de la boucle 1
Application.SheetsInNewWorkbook = ONC 'redéfinit la valeur par défaut de l'utilisateur du nombre d'onglets dans un nouveau classeur
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

 

[Raed22]

merci bien

 

[Raed22]

BOnjour
SVP comment je peux prendre les valeur des autre colonne (D,E,F...)!!

 

[Robert]

Re,

Pour éviter de perdre du temps et de l'énergie, il est bon de donner des exemples qui correspondent exactement à ta requête !... Tu le sauras pour une prochaine fois.
Le code adapté :

Sub Macro1()
Dim ONC As Byte 'déclare la variable ONC (Onglets  dans Nouveau Classeur)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NC As Byte 'déclare la variable NC (Nombre de Colonnes)
Dim D1 As Object 'déclare la variable D1 (Dictionnaire 1)
Dim D2 As Object 'déclare la variable D2 (Dictionnaire 2)
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 L As Integer 'déclare la variable L (incrément)
Dim M As Integer 'déclare la variable L (incrément)
Dim TMP1 As Variant 'déclare la variable TMP1 (tableau TeMPoraire 1)
Dim TMP2 As Variant 'déclare la variable TMP2 (tableau TeMPoraire 2)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim TVO() As Variant 'déclare la variable TVO (Tableau des Valeurs de l'Onglet)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
ONC = Application.SheetsInNewWorkbook 'récupère dans la variable ONC la valeur par défaut de l'utilisateur du nombre d'onglets dans un nouveau classeur
CA = ThisWorkbook.Path & "\" 'définit le chemin d'accès CA
Set O = Worksheets("Feuil1") 'définit l'onglet O
TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau de valeurs TV
Set D1 = CreateObject("Scripting.Dictionary") 'définit le dictionnaire 1
For I = 1 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV
    D1(TV(I, 1)) = "" 'alimente le dictionnaire D1 avec les données dans la colonne 1 de TV
Next I 'prochaine ligne de la boucle
TMP1 = D1.Keys 'récupère dans le tableau temporaire TMP1 la liste des éléments de D1 sans doublon (les Clés) (nous savons combien de fichier il faudra créer)
For J = 0 To UBound(TMP1) 'boucle 1 : sur tous les éléments du tabeau temporaire TMP1 (les fichiers)
    Set D2 = CreateObject("Scripting.Dictionary") 'définit le dictionnaire 2
    For I = 1 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV
        If TMP1(J) = TV(I, 1) Then D2(TV(I, 2)) = "" 'si l'élément TMP1(J) est égal à la donnée TV(I,2), alimente le dictionnaire D2 avec les données dans la colonne 2 de TV
    Next I 'prochaine ligne de la boucle 2
    TMP2 = D2.Keys 'récupère dans le tableau temporaire TMP2 la liste des éléments de D2 sans doublon (les Clés) (nous savons combien d'onglet aura le fichier de la boucle 1)
    Application.SheetsInNewWorkbook = D2.Count 'définit le nombre d'onglet par défaut dans un nouveau classeur
    Application.Workbooks.Add 'ajoute un classeur vierge
    Set CD = ActiveWorkbook 'définit le classeur destination CD
    CD.SaveAs CA & TMP1(J), 51 'enregistre sous le classeur destination (même chemin d'accès que le fichier d'origine avec comme nom la donnée de la boucle 1 TMP1(J)
    For K = 0 To UBound(TMP2) 'boucle 3 : sur sur tous les éléments du tabeau temporaire TMP2 (les onglets)
        L = 0 'réinitialise la variable L
        CD.Worksheets(K + 1).Name = TMP2(K) 'définit le nom TMP2(K) de l'onglet de la boucle 3
        For I = 1 To UBound(TV, 1) 'boucle 4 : sur toutes les lignes I du tableau des valeurs TV
            If TMP1(J) = TV(I, 1) And TMP2(K) = TV(I, 2) Then 'condition : si le nom du fichier et le nom de l'onglet correspondent
                L = L + 1 'incrémente L
                ReDim Preserve TVO(1 To NC - 2, 1 To L) 'redimensionne le tableau TVO (autant de lignes que TV a de colonnes -2, L colonnes)
                For M = 1 To NC - 2 'boucle 5 sur toutes les colonnes de TV - 2 (les deux premières)
                    TVO(M, L) = TV(I, M + 2) 'récupère dans la ligne M colonne L de TVO la donnée ligne I colonne M + 2 du tableau des valeur TV
                Next M
            End If 'fin de la condition
        Next I 'prochaine ligne de la boucle 4
        CD.Worksheets(K + 1).Range("A1").Resize(L, NC - 2).Value = Application.Transpose(TVO) 'renvoie le tableau TVO transposé dans A1 redimensionnée de l'onglet de la boucle 3
    Next K 'prochain onglet de la boucle 3
    CD.Close True 'ferme le classeur destination en enregistrant les modifications
Next J 'prochain fichier de la boucle 1
Application.SheetsInNewWorkbook = ONC 'redéfinit la valeur par défaut de l'utilisateur du nombre d'onglets dans un nouveau classeur
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Tu pourras avoir entre 3 et 256 colonnes de valeurs ce code fonctionnera...

 

[Raed22]

Merci bien c'est très gentille