XL 2019 EXECEL

[chac10]

Bonjou,

Je souhaiterai créer une macro qui me permette de copier une base de donnée du fichier ou se trouve la macro pour ensuite copier cette base de donnée dans plusieurs classeurs de destinations dans un premier onglet Nommé data . J'aimerais repeter cette manipulation plusieurs fois, il faudrait donc que la fois suivante, la base de donnée remplace la précédente.

Merci pour votre aide.

 

[job75]

Bonjour chac10,

En supposant que tous les classeurs sont dans un même dossier :

Sub Copier()
Dim chemin$, fichier$, plage As Range
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*")
Set plage = ThisWorkbook.Worksheets(1).Cells '1ère feuille de calcul
Application.ScreenUpdating = False
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        With Workbooks.Open(chemin & fichier)
            plage.Copy .Worksheets(1).Cells(1) 'copier-coller
            .Close True 'enregistre et ferme le fichier
        End With
    End If
    fichier = Dir
Wend
With plage(1).MergeArea: .Copy plage(1): .Merge: End With 'allège la mémoire
End Sub

A+

 

[chac10]

Bonjour JOB75,

Est ce que tu peux ajouter deux boite de dialogue me permettant de choisir le fichier a copier et le dossier.
Ca me permettra de le faire avec plusieurs base de donnees.
Merci mon ami,

chac10

 

[job75]

Bonjour chac10,

Le fichier source est celui de la macro.

Le choix du fichier de destination suffit :

Sub Copier()
Dim fichier As Variant, plage As Range
fichier = Application.GetOpenFilename("Fichiers Excel(*.xls*),*.xls*")
If fichier = False Then Exit Sub
Set plage = ThisWorkbook.Worksheets(1).Cells '1ère feuille de calcul
Application.ScreenUpdating = False
With Workbooks.Open(fichier)
    plage.Copy .Worksheets(1).Cells(1) 'copier-coller
    .Close True 'enregistre et ferme le fichier
End With
With plage(1).MergeArea: .Copy plage(1): .Merge: End With 'allège la mémoire
End Sub

A+

 

[chac10]

Merci job75 mais il faudrait que l'ensemble des fichiers sélectionner dans un dossier soient les destinataires en même temps c'est le gain de tps que je recherche. Si tu peux l'arranger...

 

[job75]

il faudrait que l'ensemble des fichiers sélectionner dans un dossier soient les destinataires en même temps

Sub Copier()
Dim plage As Range, i%
Set plage = ThisWorkbook.Worksheets(1).Cells '1ère feuille de calcul
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Classeurs Excel", "*.xls*"
    MsgBox "Sélectionnez les classeurs de destination"
    If Not .Show Then Exit Sub
    Application.ScreenUpdating = False
    For i = 1 To .SelectedItems.Count
        If .SelectedItems(i) <> ThisWorkbook.FullName Then
        With Workbooks.Open(.SelectedItems(i))
            plage.Copy .Worksheets(1).Cells(1) 'copier-coller
            .Close True 'enregistre et ferme le fichier
        End With
        End If
    Next
End With
With plage(1).MergeArea: .Copy plage(1): .Merge: End With 'allège la mémoire
End Sub

Bonne nuit.

 

[chac10]

C'est quasi parfait, est ce que tu peux faire en sorte qu'il copie la feuille dans un nouvel onglet a chaque fois que je lance la macro ?

 

[job75]

copier cette base de donnée dans plusieurs classeurs de destinations dans un premier onglet Nommé data . J'aimerais repeter cette manipulation plusieurs fois, il faudrait donc que la fois suivante, la base de donnée remplace la précédente.

Il y donc a un seul onglet de destination dans chaque fichier, nommé "data".

 

[chac10]

Bonjour Job75, effectivement au départ c'était pour une seule base de donnees finalement j'aimerai le faire à partir de plusieurs fichiers Excel avec des base de donnes différentes. Ce qui signifie que jimporterai plusieurs base de donne dans un fichier Excel. Nomme le premier onglet data n'a plus d'intérêt. Il faudrait ajouter l'onglet copie a chaque fois que je répéterai l'opération.

 

[job75]

Il faudrait ajouter l'onglet copie a chaque fois que je répéterai l'opération.

Sub Copier()
Dim plage As Range, i%
Set plage = ThisWorkbook.Worksheets(1).Cells '1ère feuille de calcul
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Classeurs Excel", "*.xls*"
    MsgBox "Sélectionnez les classeurs de destination"
    If Not .Show Then Exit Sub
    Application.ScreenUpdating = False
    For i = 1 To .SelectedItems.Count
        If .SelectedItems(i) <> ThisWorkbook.FullName Then
        With Workbooks.Open(.SelectedItems(i))
            .Worksheets.Add Before:=.Worksheets(1) 'ajoute une nouvelle feuille
            plage.Copy .Worksheets(1).Cells(1) 'copier-coller
            .Close True 'enregistre et ferme le fichier
        End With
        End If
    Next
End With
With plage(1).MergeArea: .Copy plage(1): .Merge: End With 'allège la mémoire
End Sub