Microsoft 365 Extraction de données vers plusieurs nouveaux classeurs Excel

  • Initiateur de la discussion Initiateur de la discussion TCMM
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

TCMM

XLDnaute Nouveau
Bonjour.
Je bosse présentement sur un fichier qui a cette apparence. À chaque ID correspond une adresse mail.

ID Nom Prénom Montant
1. X. Y. T
2. T. U. O
1. X. Y. J

Serait-ce possible, d'extraire grâce à une macro les informations de chaque ID vers un nouveau classeur, qui sera par la suite nommé avec l'adresse mail correspondant à l'ID. Ex du nom du classeur: XXX@hotmail.com avec toutes ses informations.
 
Solution
Bonjour TCMM, xUpsilon,

Dans le fichier joint cette macro utilise le filtre automatique :
VB:
Sub CreerFichiers()
Dim chemin$, F As Worksheet, tablo, i&, wb As Workbook
chemin = ThisWorkbook.Path & "\Mes fichiers\" 'à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier
Set F = Sheets("Inventaire") 'à adapter
tablo = Sheets("Adresse").[A1].CurrentRegion.Resize(, 2)
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
For i = 2 To UBound(tablo)
    Set wb = Workbooks.Add(xlWBATWorksheet) 'nouveau document
    With F.Cells(1).CurrentRegion
        .AutoFilter 1, tablo(i, 1) 'filtre automatique
        .Copy wb.Sheets(1).Cells(1)
        .AutoFilter
    End With...
Bonjour TCMM, xUpsilon,

Dans le fichier joint cette macro utilise le filtre automatique :
VB:
Sub CreerFichiers()
Dim chemin$, F As Worksheet, tablo, i&, wb As Workbook
chemin = ThisWorkbook.Path & "\Mes fichiers\" 'à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier
Set F = Sheets("Inventaire") 'à adapter
tablo = Sheets("Adresse").[A1].CurrentRegion.Resize(, 2)
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
For i = 2 To UBound(tablo)
    Set wb = Workbooks.Add(xlWBATWorksheet) 'nouveau document
    With F.Cells(1).CurrentRegion
        .AutoFilter 1, tablo(i, 1) 'filtre automatique
        .Copy wb.Sheets(1).Cells(1)
        .AutoFilter
    End With
    wb.Sheets(1).Columns.AutoFit 'ajustement largeurs
    wb.SaveAs chemin & tablo(i, 2) & ".xlsx", 51
    wb.Close
Next
End Sub
A+
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
11
Affichages
1 K
Retour