Fusion de Fichier VBA

[Deluxe35]

Bonjour,

Tout d'abord, je débute sur VBA.

Je souhaite copier les cellules de plusieurs fichiers Excel appartenant à un même dossier dans un nouveau fichier Excel. Je suis aujourd'hui rendu à ce code mais je rencontre une dernière problématique :
le fichier 1 s'ouvre, se colle dans le fichier final, puis le deuxième fichier s'ouvre et au lieu de se mettre à la suite, il écrase le fichier 1, etc...

Pourriez-vous m'aider?

Aujourd'hui voici mon code:

Sub recup()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.ActiveSheet 'définit l'onglet destination OD
Chemin = "C:\Users\Adrien\OneDrive Entreprise 1\Travail\Demande Agence\" 'saisir le chemin complet du dossier où se trouvent les fichiers
Fichier = Dir(Chemin & "*.xls") ' Premier fichier
Do While Fichier <> ""
Workbooks.Open Filename:=Chemin & Fichier
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Worksheets(1) 'définit l'onglet source OS (à adaper)
'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 destination OD)
Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0))
OS.Range("A1").CurrentRegion.Copy DEST 'copy la plage nommée "TOUT" de l'onglet source dans DEST
CS.Close savechanges:=False 'ferme le classeur source sans enregistrer
Fichier = Dir ' Fichier suivant
Loop
End Sub


Merci beaucoup de votre aide,

Adrien

 

[Joël GARBE]

Bonjour, et si tu mets 1 à la place de "A" , ça donne quoi ???
dans la ligne Set DEST = etc....

sinon, quant tu publies, pense qu'il y a un bouton Insérer, puis Code pour que ce soit plus lisible

 

[Deluxe35]

Bonjour Joël,

Désolé pour mes doublons!
Merci pour ton retour, j'ai donc essayé avec le code ci-dessous je prends une erreur 400. Et plus rien ne se lance du tout.

Sub recup()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.ActiveSheet 'définit l'onglet destination OD
Chemin = "C:\Users\Adrien\OneDrive Entreprise 1\Travail\" 'saisir le chemin complet du dossier où se trouvent les fichiers
Fichier = Dir(Chemin & "*.xls") ' Premier fichier
Do While Fichier <> ""
    Workbooks.Open Filename:=Chemin & Fichier
    Set CS = ActiveWorkbook 'définit le classeur source CS
    Set OS = CS.Worksheets(1) 'définit l'onglet source OS (à adaper)
    '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 destination OD)
    Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, "1").End(xlUp).Offset(1, 0))
    OS.Range("A1").CurrentRegion.Copy DEST 'copy la plage nommée "TOUT" de l'onglet source dans DEST
    CS.Close savechanges:=False 'ferme le classeur source sans enregistrer
    Fichier = Dir ' Fichier suivant
Loop
End Sub

As-tu une autre idée ...?

Merci beaucoup

Adrien

 

[Joël GARBE]

il ne faut pas de guillemet autour du 1, c'est une valeur numérique (qui correspond au NUMERO de la colonne)

 

[Deluxe35]

Merci pour ton retour mais cela ne change rien, le fichier ecrase toujours le précédent

voici le code actuel:

Sub recup()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.ActiveSheet 'définit l'onglet destination OD
Chemin = "C:\Users\Adrien\OneDrive Entreprise 1\Travail\Demande Agence\Direction\Claudine Labbe\Relevé Amadeus\Zénith\TEST MACRO\" 'saisir le chemin complet du dossier où se trouvent les fichiers
Fichier = Dir(Chemin & "*.xls") ' Premier fichier
Do While Fichier <> ""
    Workbooks.Open Filename:=Chemin & Fichier
    Set CS = ActiveWorkbook 'définit le classeur source CS
    Set OS = CS.Worksheets(1) 'définit l'onglet source OS (à adaper)
    '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 destination OD)
    Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
    OS.Range("A1").CurrentRegion.Copy DEST 'copy la plage nommée "TOUT" de l'onglet source dans DEST
    CS.Close savechanges:=False 'ferme le classeur source sans enregistrer
    Fichier = Dir ' Fichier suivant
Loop
End Sub

Aie Aie Aie

 

[Deluxe35]

J'ai aussi essayer sans l'espace devant le 1

 

[Joël GARBE]

à tenter :

si tu es sur un xlsm,
remplace Application.Rows.Count par 1048576
ou directement OD.Cells(Application.Rows.Count, 1) par :
OD.Range("A1048576")

s'il s'agit d(un xls, il faut mettre 65536 à la place de 1048576
si ce n'est toujours pas bon, c'est que je n'y comprends rien !

 

[Deluxe35]

Joël, désolé mais le dernier fichier écrase toujours avec le code

Sub recup()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.ActiveSheet 'définit l'onglet destination OD
Chemin = "C:\Users\Adrien\OneDrive Entreprise 1\Travail\" 'saisir le chemin complet du dossier où se trouvent les fichiers
Fichier = Dir(Chemin & "*.xls") ' Premier fichier
Do While Fichier <> ""
    Workbooks.Open Filename:=Chemin & Fichier
    Set CS = ActiveWorkbook 'définit le classeur source CS
    Set OS = CS.Worksheets(1) 'définit l'onglet source OS (à adaper)
    '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 destination OD)
    Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Range("A65536").End(xlUp).Offset(1, 0))
    OS.Range("A1").CurrentRegion.Copy DEST 'copy la plage nommée "TOUT" de l'onglet source dans DEST
    CS.Close savechanges:=False 'ferme le classeur source sans enregistrer
    Fichier = Dir ' Fichier suivant
Loop
End Sub

Est-ce que mes espaces sont bon dans cette ligne :

Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Range("A65536").End(xlUp).Offset(1, 0))

Je sens que j'y suis presque pourtant

 

[job75]

Bonjour Adrien, Joël,

Je ne vois qu'une explication : les cellules A1 de tous les fichiers sont vides.

A+

 

[Joël GARBE]

Effectivement, c'est une cause possible !

 

[Deluxe35]

Ouiiiiiiiii c'est ça. Ma colonne A est vide.
Cela me convient parfaitement. Merci beaucoup à toi.

Merci Joël

Adrien

 

[Deluxe35]

Je conserve ce code bien au chaud !
J'aurais quelque chose a enlever si je voulais enlever cette condition que la colonne A doit contenir quelque chose?

 

[Joël GARBE]

si la colonne A est entièrement vide, alors
OS.Range("B1").CurrentRegion.Copy DEST ) la place de OS.Range("A1").CurrentRegion.Copy DEST

en espérant que B1 ne soit pas vide !

 

[Roland_M]

Bien le bonsoir tout le monde,

perso j'aurais dis aussi merci Job75 !

 

[Joël GARBE]

c'est vrai, c'est pourquoi j'ai cliqué sur J'aime de sa réponse !!!