VBA Excel _ Macro Copier Coller aplicable à tous les fichiers du dossier source

sebgatz

XLDnaute Nouveau
Bonjour,

Je suis un peu un noob de la programmation en VBA, autant en SQL, j'arrive à réaliser des petites choses, autant en VBA c'est quasi le néant.

Dans le cadre d'un projet professionnel, je dois réaliser une macro qui centralisera les données de plusieurs fichiers excel dans un seul.

L'idée est simple:

  • Dans un dossiers seront disposés plusieurs fichiers Excel "source" et un fichier excel database
  • L'objectif est d'aller dans l'onglet "data" de chaque fichier, de copier une plage de cellule fixe, et de la coller dans l'onglet "data" du fichier database.

Si vous aviez une ébauche à me proposer, je me débrouillerai pour l'adapter (j'ai un peu le syndrome de la page blanche)
 

Robert

XLDnaute Barbatruc
Repose en paix
Re : VBA Excel _ Macro Copier Coller aplicable à tous les fichiers du dossier source

Bonjour Sebgatz et bienvenu, bonjour le forum,

peut-être comme ça (à adapter) :
Code:
Option Explicit

Sub Macro1()
Const chem As String = "C:\Robert\Tests" & "\" 'définit le chemin du dossier contenant les fichiers (à adapter)
Dim oc As Object 'déclare la variable oc (Onglet Cible)
Dim sf As Object 'déclare la variable sf (Système de Fichiers)
Dim d As Object 'déclare la variable d (Dossier)
Dim fs As Object 'déclare la variable fs (FichierS)
Dim f As Object 'déclare la variable f (Fichier)
Dim cs As Workbook 'déclare la variable cs (Classeur Source)
Dim os As Object 'déclare la variable os (Onglet Source)
Dim pl As Range 'déclare la variable pl (Plage)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)

Set oc = ThisWorkbook.Sheets("data") 'définit l'onglet cible
Set sf = CreateObject("Scripting.FileSystemObject") 'définit le système de fichiers
Set d = sf.GetFolder(chem) 'définit le dossier dans le système de fichiers
Set fs = d.Files 'définit les fichiers de ce dossier
For Each f In fs 'boucle sur tous les fichiers f
    If f.Name Like "*.xls" Then 'condition 1 : "si le fichier à une extension ".xls" (à adapter à ta version)
        Workbooks.Open (chem & f.Name) 'ouvre le fichier
        Set cs = ActiveWorkbook 'définit le classeur source
        On Error Resume Next 'gestion des erreurs
        Set os = cs.Sheets("data") 'définit l'onglet source (si l'onglet n'existe pas cela génère une erreur)
        If Err <> 0 Then 'condition 2 : si une erreur a été générée
            Err = 0 'annule l'erreur
            MsgBox "Ce classeur ne contient pas d'onglet nommé data !" 'message
            cs.Close 'ferme le classeur
            GoTo suite 'va à l'étiquette "suite"
        End If 'fin de la condition 2
        On Error GoTo 0 'annule la gestion des erreurs
        Set pl = os.UsedRange 'définit la plage pl (à adapter à ton cas (ici j'ai pris la plage des cellules éditées)
        'définit la cellule de destination dest (A1 si A1 est vide, sinon la première cellule vide de la colonne A de l'onglet "data" de ce classeur
        'selon le type de données collées il faudra définit dest différemment !
        Set dest = IIf(oc.Range("A1").Value = "", oc.Range("A1"), oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
        pl.Copy dest 'copie la plage pl et la colle dans dest
        cs.Close 'ferme le classeur
    End If 'fin de la condition 1
suite: 'étiquette
On Error GoTo 0 'annule la gestion des erreurs
Next f 'prochain fichier de la boucle
ThisWorkbook.Save 'sauve ce classeur
End Sub
 

Robert

XLDnaute Barbatruc
Repose en paix
Re : VBA Excel _ Macro Copier Coller aplicable à tous les fichiers du dossier source

Bonjour Sebgatz, bonjour le forum,

Remplace la ligne :
Code:
pl.Copy dest
par :
Code:
pl.Copy
dest.PasteSpecial (xlPasteValues)
 

sebgatz

XLDnaute Nouveau
Re : VBA Excel _ Macro Copier Coller aplicable à tous les fichiers du dossier source

Pour info voici j'ai juste ajouté la ligne "Application.DisplayAlerts = False" après le collage valeur pour éviter d'avoir à cliquer sur non à chaque fois qu'un des classeurs sources est fermé


(ça peut être utile si quelqu'un à le même besoin)
 

Discussions similaires

Réponses
6
Affichages
362

Statistiques des forums

Discussions
311 726
Messages
2 081 955
Membres
101 852
dernier inscrit
dthi16088