Copier des classeurs dans un classeur existant (VBA)

Bonjour a tous, petit coucou d'Hong Kong.

Je me permets de solliciter votre aide, debutant en vba j'ai quelques soucis de creation.

Pour le contexte, je travaille avec des chefs de projet qui remplissent leurs classeurs de projet respectifs puis je les incorpore dans un classeur "maitre", je realise cette operation tous les mois et je gère 30 projets d'ou l'utilité d'une macro.

A noter que je travaille sous excel 2007 (Oui ca existe encore)

Je souhaiterais créer une macro qui se recomposerait de la façon suivante

1.Choisir les classeurs excel que je souhaite copier, je ne souhaite pas définir un chemin d'accès predefini dans la mesure ou l'emplacement des classeurs peut évoluer.

2.Copier toutes les feuilles des classeurs dans le classeur "maitre" tout en conservant les noms d'origines des onglets.

Comme je ne suis pas venu les mains vides, voici ce que j'ai tente de réaliser, cependant ca ne fonctionne pas la macro semble tourner mais elle ne copie pas les données.

Merci infiniment a ceux qui prendront de leur temps pour m'aider.

'------------------------------------------------------------------------------

' Macro qui permet de compiler les informations contenues dans

' différents fichier pour les fusionner dans un classeur

'-------------------------------------------------------------------------------

Sub Creer_Recapitulatif()

Dim wsRecap As Worksheet 'feuille où on écrit les données

Dim wbSource As Workbook 'fichier à ouvrir

Dim DernLign As Integer 'ligne où on écrit les données

Dim vFichiers As Variant 'noms des fichiers

Dim i As Integer, k As Integer

Dim rgRecap As Range 'plage où on copie les données

' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir

vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers

' --- Vérifier qu'au moins un fichier à été sélectionné

If Not IsArray(vFichiers) Then

Debug.Print "Aucun fichier sélectionné."

MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."

Exit Sub

End If

On Error Resume Next

Application.ScreenUpdating = False

' --- Boucle à travers les fichiers

For k = 1 To UBound(vFichiers)

Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)

' C'est ici qu'on écrit les instructions

Set wbSource = Workbooks.Open(vFichiers) 'on ouvre le fichier

wbSource.Sheets.Copy After:=Sheets(ThisWorkbook.Sheets.Count)

wbSource.Close 'fermer fichier

Set wbSource = Nothing

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Next k

Application.ScreenUpdating = True

Application.StatusBar = False

End Sub

Function Selectionner_Fichiers(sTitre As String) As Variant

Dim sFiltre As String, bMultiSelect As Boolean

sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"

bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois

Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)

End Function

Personne pour aider un compatriote en détresse ?

Salut,

Une proposition de code, avec deux fichiers un maître qui va recevoir les données et un fichier qui sert d'origine.

En attendant ton retour une bonne journée.

8)

Ah j'avais mal lu ton poste.

2.Copier toutes les feuilles des classeurs dans le classeur "maitre" tout en conservant les noms d'origines des onglets.

Voila le code pour copier les onglets.

Sub Copier_origine_vers_maitre()
    Dim objOuvrir As FileDialog
    Dim objFichiers As FileDialogSelectedItems
    Dim x As Long
    Dim Wb As Workbook
    Dim wbname As String
    Dim wbOrigin As Workbook
    Dim wbDest As Workbook

    wbname = ActiveWorkbook.Name
    Set wbDest = Workbooks(wbname)

    'Affiche la fenêtre "Ouvrir"
    With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = ""
        'Efface les filtres existants.
        .Filters.Clear
        'Définit une liste de filtres pour le champ "Type de fichiers".
        .Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm"
        'Indique le type d'affichage dans la boîte de dialogue
        .InitialView = msoFileDialogViewDetails
        .Show
    End With

    'Définit le ou les fichiers à ouvrir
    Set objFichiers = Application.FileDialog(msoFileDialogOpen).SelectedItems

    'On sort si aucun fichier n'a été sélectionné
    If objFichiers.Count = 0 Then Exit Sub

    Application.ScreenUpdating = False

    'Boucle sur le ou les fichiers Excel sélectionnés pour les ouvrir
    For x = 1 To objFichiers.Count
        Set Wb = Workbooks.Open(objFichiers(x))

        Wb.Sheets.Copy After:=wbDest.Sheets(wbDest.Sheets.Count)

        'Referme le classeur sans enregistrer les modifications.
        Wb.Close False
    Next

    Application.ScreenUpdating = True

End Sub

Bonjour, désolé pour le retour tardif j'ai eu quelques complications, merci beaucoup d'avoir pris de ton temps pour m'aider c'est exactement ce que j'essayais de créer depuis quelques temps je t'en remercie grandement !

No soucis, c'est cool si ça te correspond.

Pense à

Bonne journée à bientôt