Copier une selection de cellule depuis plusieurs classeur EXCEL
heisenberg007
Messages postés
12
Statut
Membre
-
heisenberg007 Messages postés 12 Statut Membre -
heisenberg007 Messages postés 12 Statut Membre -
Bonjour,
Je souhaite récupérer grâce une Macro le contenu d'une selection de cellule à partir de plusieurs classeur Excel. Les fichiers Excel se trouve dans le même dossier Exemple:
Feuil classeur A:
Produit A Produit B Produit C
AA AC AT
AB AF AZ
AA AH AX
Feuil classeur B:
Produit A Produit B Produit C
BB AC AT
AB AF AZ
AA AH AX
CC
ZZ
Feuil classeur C:
Produit A Produit B Produit C
AA AC AT
AB AF AZ
AA AH AX
DD EE FF
XX
FF
HH
Résultat voulu:
Classeur D, Feuil Recap:
Produit A Produit B Produit C
AA AC AT
AB AF AZ
AA AH AX
BB AC AT
AB AF AZ
AA AH AX
CC
ZZ
AA AC AT
AB AF AZ
AA AH AX
DD EE FF
XX
FF
HH
Je vous remercie de votre.
Je souhaite récupérer grâce une Macro le contenu d'une selection de cellule à partir de plusieurs classeur Excel. Les fichiers Excel se trouve dans le même dossier Exemple:
Feuil classeur A:
Produit A Produit B Produit C
AA AC AT
AB AF AZ
AA AH AX
Feuil classeur B:
Produit A Produit B Produit C
BB AC AT
AB AF AZ
AA AH AX
CC
ZZ
Feuil classeur C:
Produit A Produit B Produit C
AA AC AT
AB AF AZ
AA AH AX
DD EE FF
XX
FF
HH
Résultat voulu:
Classeur D, Feuil Recap:
Produit A Produit B Produit C
AA AC AT
AB AF AZ
AA AH AX
BB AC AT
AB AF AZ
AA AH AX
CC
ZZ
AA AC AT
AB AF AZ
AA AH AX
DD EE FF
XX
FF
HH
Je vous remercie de votre.
2 réponses
-
Bonjour,
Les fichiers Excel se trouve dans le même dossier Oui, mais y a t-il un ordre dans la copie des fichiers, A et B "facile", mais avec les noms de fichiers ???? -
Voilà ce que j'ai pu faire :
Sub CumulDonnee() ' Déclaration des variables Dim i, j, k, l, m, n As Integer: i = 1 Dim classeur_1, classeur_2, classeur_3 As Workbook ' Attribut les noms des classeurs et le chemin (ici le même dossier que le classeur qui compile les données) Set ClasseurSource = ActiveWorkbook Set classeur_1 = Workbooks.Open("Classeur1.xlsx") Set classeur_2 = Workbooks.Open("Classeur2.xlsx") Set classeur_3 = Workbooks.Open("Classeur3.xlsx") Application.ScreenUpdating = False ' Traite les lignes à copier du classeur_1 - 500 lignes de A500 à C500 ' Commence à la ligne 2 (On ne prend pas en compte les en-tête des tableaux du classeur_1) For k = 2 To 500 If classeur_1.Sheets("Feuil1").Cells([k], 1) <> "" Or classeur_1.Sheets("Feuil1").Cells([k], 2) <> "" Or classeur_1.Sheets("Feuil1").Cells([k], 3) <> "" Then classeur_1.Sheets("Feuil1").Range("A" & k & ":C" & k).Copy ClasseurSource.Sheets("Données compilées").Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False i = i + 1 End If Next ' Traite les lignes à copier du classeur_2 - 500 lignes de A500 à C500 ' Commence à la ligne 2 (On ne prend pas en compte les en-tête des tableaux du classeur_2) For k = 2 To 500 If classeur_2.Sheets("Feuil1").Cells([k], 1) <> "" Or classeur_2.Sheets("Feuil1").Cells([k], 2) <> "" Or classeur_2.Sheets("Feuil1").Cells([k], 3) <> "" Then classeur_2.Sheets("Feuil1").Range("A" & k & ":C" & k).Copy ClasseurSource.Sheets("Données compilées").Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False i = i + 1 End If Next ' Traite les lignes à copier du classeur_3 - 500 lignes de A500 à C500 ' Commence à la ligne 2 (On ne prend pas en compte les en-tête des tableaux du classeur_3) For k = 2 To 500 If classeur_3.Sheets("Feuil1").Cells([k], 1) <> "" Or classeur_3.Sheets("Feuil1").Cells([k], 2) <> "" Or classeur_3.Sheets("Feuil1").Cells([k], 3) <> "" Then classeur_3.Sheets("Feuil1").Range("A" & k & ":C" & k).Copy ClasseurSource.Sheets("Données compilées").Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False i = i + 1 End If Next Application.ScreenUpdating = True ' Fermeture des classeurs classeur_1.Close classeur_2.Close classeur_3.Close End Sub
Les classeurs tests sont disponible ici :
https://www.cjoint.com/c/EJvtLqvtEOB
A voir si cela convient !-
-
Une dernière question :)
J'essaye de refaire la même chose mais cette fois avec une boucle qui parcours tout les fichiers d'un dossier. Dans mon exemple j'ai mentionné 3 classeurs mais mon cas concernent beaucoup de classeurs.
J'ai essayé cela, mais j'ai des erreurs à la compilation.
Merci pour votre aide.
Sub CumulDonnee()
' Déclaration des variables
Dim i, j, k, l, m, n As Integer: i = 1
Dim wb As Workbook
Chemin = "C:\Users\PYMI06881\Desktop\test\"
Fichier = Dir(Chemin & "*.xls")
Set ClasseurSource = ActiveWorkbook
' Attribut les noms des classeurs et le chemin (ici le même dossier que le classeur qui compile les données)
'Set ClasseurSource = ActiveWorkbook
'Set wb = Workbooks.Open(Path & "C1.xlsx")
Application.ScreenUpdating = False
Do While Fichier <> Chemin & "Compilation.xls"
Set wb = Workbooks.Open(Chemin & Fichier)
' Traite les lignes à copier du wb - 500 lignes de A500 à C500
' Commence à la ligne 2 (On ne prend pas en compte les en-tête des tableaux du wb)
For k = 2 To 500
'wb = Workbooks.Open(Fichier)
If wb.Sheets("Feuil1").Cells([k], 1) <> "" Or wb.Sheets("Feuil1").Cells([k], 2) <> "" Or wb.Sheets("Feuil1").Cells([k], 3) <> "" Then
With wb
.Sheets("Feuil1").Range("A" & k & ":J" & k).Copy
End With
With ClasseurSource.Sheets("Données compilées")
.Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
i = i + 1
End With
End If
' Fermeture des classeurs
wb.Close True
Set wb = Nothing
Fichier = Dir
Next
Loop
Application.ScreenUpdating = True
End Sub -
Je suis pas en mesure de tester le code que j'ai créer pour le moment mais j'ai tenter quelque chose quand même, si ça marche tant mieux sinon je le reverrais un peu plus tard !
Ou en attente d'un autre contributeur fan d'Excel !
Sub CumulDonnee() ' Déclaration des variables Dim i, k As Integer: i = 1 Dim wb, ClasseurSource As Workbook Dim Chemin As String ' Attribut Chemin = "C:\Users\PYMI06881\Desktop\test\" Fichier = Dir(Chemin) Set ClasseurSource = ActiveWorkbook Application.ScreenUpdating = False Do While Fichier <> "Compilation.xls" Set wb = Workbooks.Open(Fichier) ' Traite les lignes à copier du wb - 500 lignes de A500 à C500 ' Commence à la ligne 2 (On ne prend pas en compte les en-tête des tableaux du wb) For k = 2 To 500 If wb.Sheets("Feuil1").Cells([k], 1) <> "" Or wb.Sheets("Feuil1").Cells([k], 2) <> "" Or wb.Sheets("Feuil1").Cells([k], 3) <> "" Then wb.Sheets("Feuil1").Range("A" & k & ":J" & k).Copy ClasseurSource.Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False i = i + 1 End If ' Fermeture des classeurs wb.Close True Set wb = Nothing Next Fichier = Dir Loop Application.ScreenUpdating = True End Sub -
-
