Concatener données
Rmi35
-
helloh -
helloh -
Bonjour,
Je souhaite faire une macro qui concatène les données de différents fichiers mais sans succès... Quelqu'un aurait il une idée ? J'ai trouvé cette macro sur internet que j'ai legèrement modifié.
Je n'arrive pas a faire en sorte que la macro ci dessous copie des plages entières et non une ligne par une ligne...
En vous remerciant,
Rémi
Sub Creer_Recapitulatif()
Dim wbRecap As Workbook 'fichier recap
Dim wsRecap As Worksheet 'feuille où on écrit les données
Dim wbSource As Workbook 'fichier à ouvrir
Dim wsSource As Worksheet 'feuille où on cherche les données
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
Set wbRecap = ThisWorkbook 'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif
' --- 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(k)) 'on ouvre le fichier
Set wsSource = wbSource.Sheets(1) 'On copie les données de la feuille 1
' - On copie les données vers le fichier Recapitulatif
Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(1, 0) 'Offset : pour décaler
With wsSource
Range("A1:A2").Select
Selection.Copy
rgRecap = Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
rgRecap = Range("A1")
rgRecap.Offset(0, 1) = .Range("B1")
rgRecap.Offset(0, 2) = .Range("C1")
rgRecap.Offset(0, 3) = .Range("D1")
rgRecap.Offset(0, 4) = .Range("D1")
End With
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
Je souhaite faire une macro qui concatène les données de différents fichiers mais sans succès... Quelqu'un aurait il une idée ? J'ai trouvé cette macro sur internet que j'ai legèrement modifié.
Je n'arrive pas a faire en sorte que la macro ci dessous copie des plages entières et non une ligne par une ligne...
En vous remerciant,
Rémi
Sub Creer_Recapitulatif()
Dim wbRecap As Workbook 'fichier recap
Dim wsRecap As Worksheet 'feuille où on écrit les données
Dim wbSource As Workbook 'fichier à ouvrir
Dim wsSource As Worksheet 'feuille où on cherche les données
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
Set wbRecap = ThisWorkbook 'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif
' --- 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(k)) 'on ouvre le fichier
Set wsSource = wbSource.Sheets(1) 'On copie les données de la feuille 1
' - On copie les données vers le fichier Recapitulatif
Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(1, 0) 'Offset : pour décaler
With wsSource
Range("A1:A2").Select
Selection.Copy
rgRecap = Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
rgRecap = Range("A1")
rgRecap.Offset(0, 1) = .Range("B1")
rgRecap.Offset(0, 2) = .Range("C1")
rgRecap.Offset(0, 3) = .Range("D1")
rgRecap.Offset(0, 4) = .Range("D1")
End With
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
1 réponse
-
Bonjour,
Tu devrais expliquer plus en détail ce que tu veux faire. Que copier ? Où sont les fichiers, où sont les plages, où coller les plages copiées.
Cordialement.
Daniel-
Bonjour,
Merci de votre réponse.
Je voulais copier les données de différents fichiers et les assembler dans une seul fichier.
J'ai trouvé la solution, j'ai fait cela, ca fonctionne plutot bien :
Apres je ne crois pas que cette solution fonctionne sur les lecteurs réseaux... j'essaierai au travail.
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
Sub ConcaténerDonnées()
Dim SummarySheet As Worksheet
Dim NbLignes As Long
Dim WorkBk As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim vFichiers As Variant
' 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
' Créer un nouveau classeur
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' NbLignes est la variable qui indique à quelle ligne nous commencons à copier (destination) et sera utile pour la suite comme variable tampon.
NbLignes = 1
' Boucle qui va ouvrir les fichiers un par un
For k = 1 To UBound(vFichiers)
Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)
' Ouvrir le classeur à partir duquel nous allons prendre les données
Set WorkBk = Workbooks.Open(vFichiers(k))
'Utile car on ne sait pas combien de ligne nous avons à copier ; dans la dernière ligne indiquer quelles colonnes il doit copier
Dim LastRow As Long
LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
Set sourceRange = WorkBk.Worksheets(1).Range("A1:AC" & LastRow)
' Définis ou la plage commence (destination) + redéfinition taille cellules du fichier source
Set destrange = SummarySheet.Range("A" & NbLignes)
Set destrange = destrange.Resize(sourceRange.Rows.Count, _
sourceRange.Columns.Count)
' Copie les valeurs dans le fichier destination
destrange.Value = sourceRange.Value
' Augmente NbLignes du nombre de lignes qui viennent d'etre copiées.
NbLignes = NbLignes + destrange.Rows.Count
' Ferme le classeur sans sauvegarder
WorkBk.Close savechanges:=False
Next k
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Cordialement,
Rémi
-
