VBA - Enregistrement selon une valeur filtrée

Le 07/12/2024 à 06:25

Bonjour,

Je dois monter un formulaire à envoyer à 90 personnes différentes, chacune ayant des informations distinctes dans certaines colonnes. Mon fichier MASTER est complété avec tous les noms de ces personnes dans une colonne, et je veux monter un code VBA qui va enregistrer une version du fichier pour chacune de ces personnes en n'incluant que leurs informations.

Mon VBA est presque complété. Excel va chercher chaque valeur unique dans ma colonne Document, filtre selon la valeur unique et va enregistrer sous le fichier selon la valeur du document dans un dossier choisi en gardant toutes les autres pages, formules et autres du document principal. Le seul problème que je rencontre est qu'il ne supprime pas les lignes qui n'appartiennent pas à la valeur unique: il va supprimer les lignes DE cette valeur unique.

Par exemple, le fichier enregistré sera sous le nom de Justin (comme indiqué dans la colonne Document), mais, plutôt que de ne garder que les lignes correspondantes à la cellule Justin, il va garder les 89 autres noms et leurs informations.

Je n'arrive pas à le retourner de bord (je dois avouer que ChatGPT est celui qui a principalement monté le code, je ne suis pas complètement à l'aise avec VBA). Est-ce que quelqu'un ici est capable de m'aider à le corriger?

Voici le code:

    Sub SplitTableByColumn()
    Dim wsSource As Worksheet
    Dim tbl As ListObject
    Dim colName As String
    Dim uniqueValues As Collection
    Dim cell As Range
    Dim filterField As Integer
    Dim savePath As String
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    Dim value As Variant
    Dim wsName As String

    ' Définir la feuille source et le tableau

    Set wsSource = ThisWorkbook.Sheets("Data") ' Nom de la feuille contenant le tableau

    Set tbl = wsSource.ListObjects("CleanAccounts") ' Nom du tableau structuré

    ' Nom de la colonne pour scinder les données

    colName = "Document" ' Nom de la colonne utilisée pour filtrer

    ' Identifier l'index du champ de la colonne

    On Error Resume Next

    filterField = tbl.ListColumns(colName).Index

    On Error GoTo 0

    If filterField = 0 Then

    MsgBox "La colonne spécifiée n'existe pas dans le tableau.", vbExclamation

    Exit Sub

    End If

    ' Obtenir les valeurs uniques de la colonne

    Set uniqueValues = New Collection

    On Error Resume Next

    For Each cell In tbl.ListColumns(colName).DataBodyRange

    uniqueValues.Add cell.Value, CStr(cell.Value)

    Next cell

    On Error GoTo 0

    ' Sélectionner le dossier de sauvegarde

    With Application.FileDialog(msoFileDialogFolderPicker)

    .Title = "Sélectionnez un dossier pour enregistrer les fichiers"

    If .Show = -1 Then

    savePath = .SelectedItems(1) & "\"

    Else

    MsgBox "Aucun dossier sélectionné.", vbExclamation

    Exit Sub

    End If

    End With

    ' Boucler sur les valeurs uniques et enregistrer chaque fichier

    Application.ScreenUpdating = False

    For Each value In uniqueValues

    ' Appliquer le filtre

    tbl.Range.AutoFilter Field:=filterField, Criteria1:=value

    ' Supprimer les lignes non visibles

    On Error Resume Next

    tbl.DataBodyRange.SpecialCells(xlCellTypeVisible).EntireRow.Copy ' Copier les lignes visibles

    tbl.DataBodyRange.EntireRow.Delete ' Supprimer toutes les lignes du tableau

    wsSource.Range("A7").PasteSpecial Paste:=xlPasteValues ' Coller uniquement les visibles

    wsSource.Range("A7").PasteSpecial Paste:=xlPasteFormats

    On Error GoTo 0

    ' Créer un nouveau classeur

    wsSource.Copy

    Set wbNew = ActiveWorkbook

    ' Identifier la feuille avec le tableau et ajuster les lignes

    Set wsNew = wbNew.Sheets(1)

    wsNew.Name = "Data"

    ' Supprimer les filtres

    tbl.AutoFilter.ShowAllData

    ' Enregistrer le fichier

    wsName = CStr(value)

    wbNew.SaveAs Filename:=savePath & wsName & ".xlsx", FileFormat:=xlOpenXMLWorkbook

    wbNew.Close SaveChanges:=False

    Next value

    Application.ScreenUpdating = True

    MsgBox "Les fichiers ont été enregistrés avec succès dans : " & savePath, vbInformation

    End Sub

Merci!

Le 07/12/2024 à 13:21

Bonjour,

vous devriez lire la charte de ce forum et notamment

4. Joignez (si possible) un fichier pour augmenter vos chances d'obtenir de l'aide en cliquant sur le bouton Fichier de l'éditeur. Si votre fichier est trop lourd ou contient des données personnelles, créez une version allégée de votre fichier avec juste assez d'informations pour permettre de comprendre votre problème. Dans tous les cas, ne postez JAMAIS de fichiers avec des informations personnelles ou confidentielles (cet utilitaire peut vous aider à les retirer).

A+

Le 07/12/2024 à 15:33

Bonjour browniiesx, JExceL2fr,

Votre problème semble provenir de la manière dont vous gérez le filtrage et la suppression des lignes dans le tableau. Dans votre code actuel, vous copiez les lignes visibles après le filtrage, mais vous supprimez ensuite toutes les lignes du tableau, y compris celles correspondant à la valeur unique. Voici une version corrigée de votre code :

Sub SplitTableByColumn()
    Dim wsSource As Worksheet
    Dim tbl As ListObject
    Dim colName As String
    Dim uniqueValues As Collection
    Dim cell As Range
    Dim filterField As Integer
    Dim savePath As String
    Dim wbNew As Workbook
    Dim value As Variant

    ' Définir la feuille source et le tableau
    Set wsSource = ThisWorkbook.Sheets("Data") ' Nom de la feuille contenant le tableau
    Set tbl = wsSource.ListObjects("CleanAccounts") ' Nom du tableau structuré

    ' Nom de la colonne pour scinder les données
    colName = "Document" ' Nom de la colonne utilisée pour filtrer

    ' Identifier l'index du champ de la colonne
    On Error Resume Next
    filterField = tbl.ListColumns(colName).Index
    On Error GoTo 0

    If filterField = 0 Then
        MsgBox "La colonne spécifiée n'existe pas dans le tableau.", vbExclamation
        Exit Sub
    End If

    ' Obtenir les valeurs uniques de la colonne
    Set uniqueValues = New Collection
    On Error Resume Next
    For Each cell In tbl.ListColumns(colName).DataBodyRange
        uniqueValues.Add cell.Value, CStr(cell.Value)
    Next cell
    On Error GoTo 0

    ' Sélectionner le dossier de sauvegarde
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Sélectionnez un dossier pour enregistrer les fichiers"
        If .Show = -1 Then
            savePath = .SelectedItems(1) & "\"
        Else
            MsgBox "Aucun dossier sélectionné.", vbExclamation
            Exit Sub
        End If
    End With

    ' Boucler sur les valeurs uniques et enregistrer chaque fichier
    Application.ScreenUpdating = False
    For Each value In uniqueValues
        ' Appliquer le filtre
        tbl.Range.AutoFilter Field:=filterField, Criteria1:=value

        ' Créer un nouveau classeur
        wsSource.Copy
        Set wbNew = ActiveWorkbook

        ' Supprimer les lignes non visibles dans le nouveau classeur
        With wbNew.Sheets(1)
            On Error Resume Next
            .ListObjects(1).DataBodyRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
            On Error GoTo 0
        End With

        ' Enregistrer le fichier
        wbNew.SaveAs Filename:=savePath & CStr(value) & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        wbNew.Close SaveChanges:=False
    Next value
    Application.ScreenUpdating = True

    ' Enlever le filtre de la source
    wsSource.AutoFilterMode = False

    MsgBox "Les fichiers ont été enregistrés avec succès dans : " & savePath, vbInformation
End Sub
Le 09/12/2024 à 15:33

Bonjour Abderrahmane BENALI,

Merci pour la réponse! Malheureusement, le code semble toujours vouloir seulement effacer les lignes autres que celle que la valeur unique avec ceci.

Je mets en fichier joint un exemple de fichier avec votre code mis à jour. Merci pour votre aide!

6example-vba-browniiesx.xlsm (215.20 Ko)
Rechercher des sujets similaires à "vba enregistrement valeur filtree"