IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Macro pour filtrer et exporter une liste vers plusieurs fichiers


Sujet :

Macros et VBA Excel

Vue hybride

Message précédent Message précédent   Message suivant Message suivant
  1. #1
    Membre averti
    Homme Profil pro
    Chef de projet MOA
    Inscrit en
    Avril 2023
    Messages
    38
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Aisne (Picardie)

    Informations professionnelles :
    Activité : Chef de projet MOA

    Informations forums :
    Inscription : Avril 2023
    Messages : 38
    Par défaut Macro pour filtrer et exporter une liste vers plusieurs fichiers
    Bonjour à tous

    je dispose d'un onglet avec 3 champs (qui est aussi une liste)

    Nom : Liste.JPG
Affichages : 185
Taille : 20,7 Ko

    je souhaiterais pouvoir lancer une macro
    1) qui crée les fichiers Excel dans les répertoires mentionnés (3 fichiers dans 2 répertoires dans le cas ci dessus)
    2) et dans chaque fichier il y aura un onglet comprenant les données respectives de la colonne "Valeurs"

    merci pour vos idées
    Images attachées Images attachées  

  2. #2
    Rédacteur
    Avatar de Philippe Tulliez
    Homme Profil pro
    Formateur, développeur et consultant Excel, Access, Word et VBA
    Inscrit en
    Janvier 2010
    Messages
    13 179
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Belgique

    Informations professionnelles :
    Activité : Formateur, développeur et consultant Excel, Access, Word et VBA

    Informations forums :
    Inscription : Janvier 2010
    Messages : 13 179
    Billets dans le blog
    53
    Par défaut
    Bonjour,
    Pour créer un répertoire, on peut utiliser la fonction MkDir en vérifiant auparavant son existence avec Dir ou bien avec le FileSystemObject voir le lien

    Exemple avec MkDir et Dir
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    Sub t()
      Dim CurrentPath As String
      Dim SubFolder As String
      Dim FullPath As String
      CurrentPath = ThisWorkbook.Path  ' Nom du répertoire courant de l'application
      SubFolder = "TinTin"             ' Nom du sous-dossier à créer
      FullPath = CurrentPath & "\" & SubFolder
      If Dir(FullPath, vbDirectory) = "" Then MkDir FullPath
    End Sub
    La méthode Add de la collection Workbooks permet d'ouvrir un nouveau classeur. Exemple : Workbooks.Add
    Une fois créé, il devient le classeur actif (ActiveWorkbook) et à l'aide de la méthode SaveAs de celui-ci et en lui passant les bonnes valeurs à ses arguments, on pourra donc l'enregistrer
    Philippe Tulliez
    Ce que l'on conçoit bien s'énonce clairement, et les mots pour le dire arrivent aisément. (Nicolas Boileau)
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter
    Mes tutoriels : Utilisation de l'assistant « Insertion de fonction », Les filtres avancés ou élaborés dans Excel
    Mon dernier billet : Utilisation de la fonction Dir en VBA pour vérifier l'existence d'un fichier

  3. #3
    Membre Expert
    Inscrit en
    Décembre 2002
    Messages
    993
    Détails du profil
    Informations forums :
    Inscription : Décembre 2002
    Messages : 993
    Par défaut
    Salut, voici une possibilité, à adapter si nécessaire:

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    Sub CopierValeurs()
        Dim ws As Worksheet
        Dim rng As Range
        Dim cell As Range
        Dim wb As Workbook
        Dim destWs As Worksheet
        Dim destCell As Range
        Dim chemin As String
        Dim fichier As String
     
        Application.ScreenUpdating = False
     
        Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" si nécessaire
        Set rng = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
     
        For Each cell In rng
            chemin = cell.Offset(0, 1).Value
            fichier = cell.Offset(0, 2).Value
     
            If cell.Value <> "" Then
                ' Ouvrir le classeur de destination
                On Error Resume Next ' Ignorer l'erreur si le fichier n'existe pas
                Set wb = Workbooks.Open(chemin & fichier)
                On Error GoTo 0 ' Réactiver les erreurs
     
                ' Si le classeur de destination n'existe pas, le créer
                If wb Is Nothing Then
                    Set wb = Workbooks.Add
                    wb.SaveAs chemin & fichier
                End If
     
                ' Définir la feuille de travail et la cellule de destination
                Set destWs = wb.Sheets(1)
                Set destCell = destWs.Range("A" & destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1)
     
                ' Copier la valeur dans la cellule de destination
                destCell.Value = cell.Value
     
                ' Sauvegarder et fermer le classeur de destination
                wb.Close SaveChanges:=True
                Set wb = Nothing
            End If
        Next cell
     
        Application.ScreenUpdating = True
     
        MsgBox "Traitement terminé!", vbInformation
     
    End Sub
    [EDIT] Comme je n'étais pas très satisfait de ma première macro, qui éffectue des opérations d'ouverture/fermeture de fichier pour chaque cellule, je l'ai retravaillée. Maintenant il n'y a plus qu'une ouverture/fermeture par groupe de cellules ayant le même chemin et fichier.
    Résultat pour traiter 100 cellules avec la première macro: 68 secondes, avec la 2è version: 2.1 secondes. A toi de choisir.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    Sub CopierValeurs2()
        Dim ws As Worksheet
        Dim rng As Range
        Dim cell As Range
        Dim wb As Workbook
        Dim destWs As Worksheet
        Dim destCell As Range
        Dim chemin As String
        Dim fichier As String
        Dim dict As Object
        Dim key As Variant
        Dim values As Object
        Dim value As Variant
     
        ' Désactiver l'affichage des fenêtres
        Application.ScreenUpdating = False
     
        Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" si nécessaire
        Set rng = ws.Range("A2:A" & ws.Cells(ws.Rows.Rows.Count, "A").End(xlUp).Row)
     
        ' Créer un dictionnaire pour regrouper les valeurs par fichier
        Set dict = CreateObject("Scripting.Dictionary")
     
        ' Parcourir chaque cellule de la plage
        For Each cell In rng
            chemin = cell.Offset(0, 1).value
            fichier = cell.Offset(0, 2).value
            If cell.value <> "" Then
                ' Créer la clé du dictionnaire
                key = chemin & fichier
     
                ' Ajouter la valeur à la liste pour cette clé
                If dict.Exists(key) Then
                    dict(key).Add cell.value
                Else
                    Set dict(key) = CreateObject("System.Collections.ArrayList")
                    dict(key).Add cell.value
                End If
            End If
        Next cell
     
        ' Parcourir chaque clé du dictionnaire
        For Each key In dict.Keys
            ' Ouvrir le classeur de destination
            On Error Resume Next ' Ignorer l'erreur si le fichier n'existe pas
            Set wb = Workbooks.Open(key)
            On Error GoTo 0 ' Réactiver les erreurs
     
            ' Si le classeur de destination n'existe pas, le créer
            If wb Is Nothing Then
                Set wb = Workbooks.Add
                wb.SaveAs key
            End If
     
            ' Définir la feuille de travail et la cellule de destination
            Set destWs = wb.Sheets(1)
            Set destCell = destWs.Range("A" & destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1)
     
            ' Copier les valeurs dans les cellules de destination
            Set values = dict(key)
            For Each value In values
                destCell.value = value
                Set destCell = destCell.Offset(1, 0)
            Next value
     
            ' Sauvegarder et fermer le classeur de destination
            wb.Close SaveChanges:=True
            Set wb = Nothing
        Next key
     
        Application.ScreenUpdating = True
     
        MsgBox "Traitement terminé!", vbInformation
     
    End Sub

  4. #4
    Membre averti
    Homme Profil pro
    Chef de projet MOA
    Inscrit en
    Avril 2023
    Messages
    38
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Aisne (Picardie)

    Informations professionnelles :
    Activité : Chef de projet MOA

    Informations forums :
    Inscription : Avril 2023
    Messages : 38
    Par défaut
    Merci Franc

    ça fonctionne parfaitement, je vais l'adapter (rajouter les titres et des colonnes de valeur)

  5. #5
    Membre averti
    Homme Profil pro
    Chef de projet MOA
    Inscrit en
    Avril 2023
    Messages
    38
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Aisne (Picardie)

    Informations professionnelles :
    Activité : Chef de projet MOA

    Informations forums :
    Inscription : Avril 2023
    Messages : 38
    Par défaut
    Bonjour Franc

    en fait je n'arrive pas à généraliser, j'essaie de travailler sur plusieurs colonnes de valeur, ça peut être 2, voire 3, 4, 5...
    Nom : Liste.JPG
Affichages : 146
Taille : 38,6 Ko

    j'ai remplacé la formule de sélection de rng par
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Set rng = ws.Range("A2:B" & ws.Cells(ws.Rows.Rows.Count, "A").End(xlUp).Row)
    pour ce qui est du nombre de lignes rester sur la colonne A ça va bien; mais y aurait il une formulation plus générique , qui sélectionnerait toutes les colonnes de valeur (Valeur1, 2, 3, 4,5...) - sans bien sûr les 2 dernières colonnes qui comprennent le nom du répertoire et du fichier
    J'imagine qu'il faut créer une variable pour stocker le nombre de colonnes de valeurs, et ce, pour
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    For Each cell In rng
            chemin = cell.Offset(0, NbCol+1).value
            fichier = cell.Offset(0, NbCol+2).value
    ensuite quand on stocke
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    dict(key).Add cell.value
    , il faudrait quelque part aussi indiquer la ligne et la colonne

    et enfin quand on copie les valeurs dans les cellules de destination il faudrait le faire en fonction des lignes et des colonnes initiales

    cerise sur le gâteau il faudrait copier la première ligne de titres aussi dans chaque fichier cible, j'imagine qu'il faut créer un Dict2 ?

    Voilà, si tu as un peu de "temps de cerveau disponible" ça m'aiderait bien

  6. #6
    Membre Expert
    Inscrit en
    Décembre 2002
    Messages
    993
    Détails du profil
    Informations forums :
    Inscription : Décembre 2002
    Messages : 993
    Par défaut
    Salut, en espérant avoir bien compris ta demande, teste ceci:

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    Sub CopierValeurs()
        Dim ws As Worksheet
        Dim rng As Range
        Dim cell As Range
        Dim wb As Workbook
        Dim destWs As Worksheet
        Dim destCell As Range
        Dim dict As Object
        Dim key As Variant
        Dim values As Object
        Dim value As Variant
        Dim NbCol As Long
        Dim i As Long
     
        ' Désactiver l'affichage des fenêtres
        Application.ScreenUpdating = False
     
        Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" si nécessaire
        NbCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column - 2 ' Nombre de colonnes de valeurs
        Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(ws.Rows.Count, "A").End(xlUp).Resize(, NbCol))
     
        ' Créer un dictionnaire pour regrouper les valeurs par fichier
        Set dict = CreateObject("Scripting.Dictionary")
     
        ' Parcourir chaque cellule de la plage
        For Each cell In rng
            If cell.value <> "" Then
                ' Créer la clé du dictionnaire
                key = ws.Cells(cell.Row, NbCol + 1).value & ws.Cells(cell.Row, NbCol + 2).value
     
                ' Ajouter la valeur à la liste pour cette clé
                If dict.Exists(key) Then
                    dict(key).Add cell.Address(False, False) & ":" & cell.value
                Else
                    Set dict(key) = CreateObject("System.Collections.ArrayList")
                    dict(key).Add cell.Address(False, False) & ":" & cell.value
                End If
            End If
        Next cell
     
        ' Parcourir chaque clé du dictionnaire
        For Each key In dict.Keys
            ' Ouvrir le classeur de destination
            On Error Resume Next ' Ignorer l'erreur si le fichier n'existe pas
            Set wb = Workbooks.Open(key)
            On Error GoTo 0 ' Réactiver les erreurs
     
            ' Si le classeur de destination n'existe pas, le créer
            If wb Is Nothing Then
                Set wb = Workbooks.Add
                wb.SaveAs key
            End If
     
            ' Définir la feuille de travail et la cellule de destination
            Set destWs = wb.Sheets(1)
     
            ' Copier les titres dans le classeur de destination
            If destWs.Cells(1, 1).value = "" Then
                ws.Range(ws.Cells(1, 1), ws.Cells(1, NbCol)).Copy destWs.Cells(1, 1)
            End If
     
            ' Copier les valeurs dans les cellules de destination
            Set values = dict(key)
            For Each value In values
                Set destCell = destWs.Range(Split(value, ":")(0))
                destCell.value = Split(value, ":")(1)
            Next value
     
            ' Sauvegarder et fermer le classeur de destination
            wb.Close SaveChanges:=True
            Set wb = Nothing
        Next key
     
        Application.ScreenUpdating = True
     
        MsgBox "Traitement terminé!", vbInformation
     
    End Sub

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. [XL-365] Macro pour filtrer et isoler une ligne
    Par revisor dans le forum Macros et VBA Excel
    Réponses: 5
    Dernier message: 16/11/2020, 09h23
  2. [XL-2010] Macro pour rechercher valeur dans une liste et copier valeur associée d'une autre colonne
    Par DeathCrow83 dans le forum Macros et VBA Excel
    Réponses: 6
    Dernier message: 13/05/2017, 16h58
  3. [A-00] exporter une liste vers excel
    Par Slici dans le forum VBA Access
    Réponses: 5
    Dernier message: 06/03/2009, 14h49
  4. [Macro]exporter une table vers un fichier.csv
    Par samca dans le forum IHM
    Réponses: 2
    Dernier message: 24/04/2007, 21h25
  5. Réponses: 3
    Dernier message: 06/01/2007, 17h44

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo