Macro répertoire copie de données

Bonjour le Forum,

Je viens vers vous dans l'espoir de gagner du temps journalièrement en m'évitant de faire la même manipulation chaque jour une quarantaine de fois en copiant des lignes de données à des fins de mise à jour.

Je dispose d'un répertoire contenant une quarantaine de fichiers ayant tous la même structure avec dans chaque fichier une 1re feuille "Base" contenant des lignes de données à ventiler via une codification dont je dispose déjà.

L'idée serait celle d'un fichier maître placé dans le répertoire actif (contenant les autres fichiers à traiter) où j'aurais à coller mes nouvelles lignes de données dans sa 1re feuille en conservant la sélection.

Ce fichier maître contiendrait une macro à lancer qui ferait les choses suivantes :

1/- Copie les lignes déjà sélectionnées de ma 1re feuille

2/- Ouvre un 1er fichier (quelque soit son nom) du répertoire actif

3/- Copie les lignes sélectionnées dans la 1re feuille "Base" du fichier ainsi ouvert à la suite immédiate des lignes de données existantes déjà et conserve ces dernières lignes sélectionnées

4/- Ferme le fichier en enregistrant les modifications

5/- Ouvre le ficher suivant pour le traiter de la même manière et ainsi de suite jusqu'au dernier fichier

L'option barre de progression serait un must

Merci par avance

Bonjour Fouggy, bonjour le forum,

Essaie comme ça :

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CS = ThisWorkbook 'définit le classeur source
CS.Worksheets(1).Activate 'active le premier onglet du classeur
Set PL = Selection 'définit la plage PL (les cellules sélectionnées)
CA = ThisWorkbook.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier d'extension xlsx ayant CA comme chemin d'accès (extension à adapter)
Do While F <> "" 'exécute tant qu'il existe des fichiers
    Set CD = Application.Workbooks.Open(CA & F) 'définit le classeur destination CD en l'ouvrant
    Set OD = CD.Worksheets("Base") 'définit l'onglet source OD
    Set DEST = OS.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la première cellule vide DEST de la colonne A de l'onglet destination
    PL.Copy DEST 'copie la plage PL et la colle dans DEST
    CD.Close False 'ferme le classeur destination sans enregistrer
    F = Dir 'définit le prochain fichier F d'extension xlsx ayant CA comme chemin d'accès
Loop 'boucle
End Sub

Merci ThauTheme pour ta réponse mais après avoir pris toutes les précautions de tests multiples il bug sur la ligne surlignée en jaune suivante :

Set DEST = OS.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0)

après avoir annoncé une erreur d'exécution 424

Re,

Oui il y a une erreur ! Remplace :

Set DEST = OS.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 

par :

Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 

Ça devrait aller mieux... Je me demande à quoi ça sert de commenter les codes...

Re ThauThème,

Bien sûr que les explications des codes sont précieuses car c'est comme cela qu'on avance même si les rythmes de chacun sont différents ! et c'est comme cela que j'arrive maintenant à faire un certain nombre de codes ou en en modifiant/adaptant d'autres déjà postés sur ce site sans solliciter le forum.

"OS" n'existant pas dans les variables déclarées cela aurait dû sauter aux yeux même sans explication, mais bon j'ai pas encore tous les réflexes non plus, lol.

En revanche dans ma demande initiale je demandais (point numéro 4) à ce que les fichiers traités soient enregistrés avant fermeture chose que ne fait pas ta codification et c'est bien grâce à tes explications que j'ai modifié la ligne de code correspondante en remplaçant "False" par "True"

Alors oui, cela va déjà mieux mais c'est malheureusement pas encore ça sur deux points précis qui dépassent mes compétences actuelles :

Le premier point est qu'il est absolument nécessaires que les lignes copiées dans les onglets "Base" de chaque classeur de destination restent les seules et uniques à rester sélectionnées après copie comme précisé dans ma demande. Cela est important car j'applique ensuite au répertoire en question une autre codification dont la première action est :

"Ouvre chaque classeur du répertoire et copie les lignes sélectionnées de la Feuille "Base" dans toutes les autres feuilles à la suite des lignes déjà existantes".

Enfin, en fin de traitement ta codification revient sur le fichier maître pour l'ouvrir suscitant le message excel comme quoi le fichier est déjà ouvert... et qu'en le réouvrant on risque de perdre des données...

Yeeeppp,

J'ai aussi réussi à modifier les extensions (*.xlsm) de ta codification, mes classeurs comportant des macros

@+++

Re,

Pour la sélection des cellules copiées, le test chez moi fonctionne !... Le code modifié. Dis-nous si ça convient ou pas :

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CS = ThisWorkbook 'définit le classeur source
CS.Worksheets(1).Activate 'active le premier onglet du classeur
Set PL = Selection 'définit la plage PL (les cellules sélectionnées)
CA = ThisWorkbook.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsm") 'définit le premier fichier d'extension xlsm ayant CA comme chemin d'accès (extension à adapter)
Do While F <> "" 'exécute tant qu'il existe des fichiers
    If Not F.Name = CS.Name Then 'condition : si le fichier F n'est pas ce classeur, le classeur source CS
        Set CD = Application.Workbooks.Open(CA & F) 'définit le classeur destination CD en l'ouvrant
        Set OD = CD.Worksheets("Base") 'définit l'onglet source OD
        Set DEST = OS.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la première cellule vide DEST de la colonne A de l'onglet destination
        PL.Copy DEST 'copie la plage PL et la colle dans DEST
        CD.Close True 'ferme le classeur destination en enregistrant
        F = Dir 'définit le prochain fichier F d'extension xlsm ayant CA comme chemin d'accès
    End If 'fin de la condition
Loop 'boucle
End Sub

J'ai procédé à nouveau à de multiples tests et ... avec ta 1re codification le message excel ne revient plus !!! donc la condition que tu as rajouté ne se justifie plus.

En revanche, j'ai tourné, viré, changé de version d'excel, de pc... et rien n'y fait, les fichiers sont correctement traités mais lorsque je les réouvre les lignes copiées ne sont pas sélectionnées.

Tu dis que cela fonctionne de ton côté et je veux bien te croire, mais je ne compte pas passer chez toi tous les jours pour traiter mes fichiers, j'espère que tu peux comprendre...

Cela proviendrait-il de mes fichiers ???

Du coup, je poste 4 fichiers à tester de ton côté, si tu le veux bien : Le 1er dans lequel j'ai inséré ton code avec en feuille1 les lignes présélectionnées et 3 autres qui sont les 3 1ers fichiers du répertoire à traiter.

Dans l'attente de ton retour...

@+++

7macro1test.xlsm (16.23 Ko)

Re,

Voilà une idée qu'elle est bonne ! Je regarde ça avec de vrais fichiers... Et je te dis...

Super.

Merki

Re,

Yes ! bel et bien des erreurs sur mon code. Le voici corrigé et testé. Les 3 fichiers ont tous 40 lignes en plus...

C'était la ligne F = Dir qui était à l'intérieur de la condition alors qu'elle devait se trouver en dehors juste avant la boucle Loop. Mes essais avaient fonctionné chez mois car le fichier maître était xlsm et les autres xlsx...

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CS = ThisWorkbook 'définit le classeur source
CS.Worksheets(1).Activate 'active le premier onglet du classeur
Set PL = Selection 'définit la plage PL (les cellules sélectionnées)
CA = ThisWorkbook.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsm") 'définit le premier fichier d'extension xlsm ayant CA comme chemin d'accès (extension à adapter)
Do While F <> "" 'exécute tant qu'il existe des fichiers
    If Not F = CS.Name Then 'condition : si le fichier F n'est pas ce classeur, le classeur source CS
        Set CD = Application.Workbooks.Open(CA & F) 'définit le classeur destination CD en l'ouvrant
        Set OD = CD.Worksheets("Base") 'définit l'onglet source OD
        Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la première cellule vide DEST de la colonne A de l'onglet destination
        PL.Copy DEST 'copie la plage PL et la colle dans DEST
        CD.Close True 'ferme le classeur destination en enregistrant
    End If 'fin de la condition
    F = Dir 'définit le prochain fichier F d'extension xlsm ayant CA comme chemin d'accès
Loop 'boucle
End Sub

Bonjour,

Une méthode un peu similaire à celle de ThauThème, que j'utilise depuis quelques années pour traiter successivement plusieurs fichiers.

(Exemple en pièce jointe).

J'ai mis un compteur qui affiche sur le fichier "Maître" le n° du fichier traité (1/N) en cellule G1. C'est facilement transposable en barre de progression.

A priori et suite à mes différents essais la sélection est maintenue dans les fichiers traités

J'utilise une petite fonction (Checkpath) qui rajoute un "\" si nécessaire.

L'exécution du programme se fait depuis le fichier maître à partir d'un bouton. Tu peux éventuellement rajouter une demande de confirmation au cas où l'utilisateur aurait oublié de sélection les lignes à rajouter.

Voici le code principal:

Public Sub Traitement()
    On Error Resume Next
    Dim RepSource As String
    Dim DerniereLigne As Long

    Dim F As String
    Dim NbFic As Long
    Dim Compteur As Long
    Dim Tableur As New Excel.Application

    RepSource = ActiveWorkbook.Path
    Selection.Copy
    'Tableur.Visible = False
    RepSource = CheckPath(RepSource)

    ' Nombre de fichiers dans le dossier
    ' répondant au masque DEP*.XLS
    F = Dir(RepSource & "DEP*.xls", vbNormal)

    Do While F <> ""
        NbFic = NbFic + 1
        F = Dir()
    Loop

    Compteur = 0

    F = Dir(RepSource & "DEP*.xls", vbNormal)
    Do While F <> ""
        If F <> "" Then
            Compteur = Compteur + 1
            Range("G1").Select
            ActiveCell.Value = "Fichier n°" & Compteur & "/" & NbFic

            'Ouverture du fichier Excel
            Tableur.Workbooks.Open (RepSource & F)

            'TRAITEMENT
            DerniereLigne = Tableur.Sheets("Base").Cells(Application.Rows.Count, 1).End(xlUp).Row 'Dernière Ligne du tableur utilisée
            Tableur.Cells(DerniereLigne + 1, 1).Select
            Tableur.Sheets("Base").Paste

            'Enregistrement et fermeture
            Tableur.ActiveWorkbook.Save
            Tableur.ActiveWorkbook.Close
            Tableur.Quit
        End If
        'Fichier suivant
        F = Dir()
    Loop
    Set Tableur = Nothing
    MsgBox "Traitement terminé"

End Sub

'*********************************************
'* Ajoute un Slash si nécessaire à un chemin *
'*********************************************
Function CheckPath(Chemin As String) As String
  CheckPath = ""
  If Right(Chemin, 1) = "\" Then
    CheckPath = Chemin
  Else
    CheckPath = Chemin & "\"
  End If
End Function

Bien cordialement,

2dep77.xls (14.50 Ko)
1dep75.xls (14.50 Ko)
1dep78.xls (14.50 Ko)

Oupsssssssss Tauthème, Slt Gnin,

Les résultats restent les mêmes de mon côté, voire, se compliquent...

Malgré la modification de code apportée ce matin et testée, les résultats sont les mêmes.

Avec les 2 codes, les lignes sélectionnées sont effectivement copiées où il faut dans chaque fichier mais... elles ne restent pas sélectionnées. En clair, il faut que lorsqu'on ouvre les fichiers ainsi traités, les lignes précédemment copiées, via le code, restent sélectionnées en... "bleu" (Résultat attendu en fichier joint).

Constat effectué sur mon pc portable HP 2007

Win XP Pro 2002 (32 bits)

Excel 2010

Sur mon pc portable ASUS 2014

Win 8.1

Excel 2007

Le même code ouvre, copie les lignes souhaitées et referme chaque fichier jusqu'au dernier puis recommence la procédure à l'infini, recopiant à chaque fois les mêmes lignes !!!

Seul un arrêt manuel de la procédure permet de bloquer la procédure avec en message de débogage le pointage de la ligne :

"Set CD = Application.Workbooks.Open(CA & F) 'définit le classeur destination CD en l'ouvrant"

Voili, voilou, je crois qu'on est pas sorti de l'auberge

Gnin, j'essaie de tester ce que tu proposes dès que je peux.

@+++

Re,

Je passe la main... Utiliser Selection me semble peu fiable. Pour ma part, je stockerais dans une cellule d'un onglet du fichier destination, l'adresse de la plage au moment du collage. Puis j'irai la récupérer à la réouverture pour la sélectionner...

Rechercher des sujets similaires à "macro repertoire copie donnees"