Améliorer une macro pour fusion de fichiers

[samo.m]

Bonjour à tous !

Grâce aux utilisateurs du forum, je dispose de cette macro qui permet de choisir les fichiers que je souhaite fusionner.
Tous les fichiers sont ensuite regrouper dans un nouveau fichier vierge.
Le premier fichier est copié entièrement mais les fichiers suivants sont copiés (verticalement) à partir de la 5ième ligne pour ne pas copier des lignes redondantes.
Je ne connais pas la taille des fichiers en ce qui concerne les lignes, je sais simplement que les colonnes vont jusqu'à "QOD" (Oui je sais c'est très long ahah)
Le problème avec cette macro est qu'elle me copie seulement les colonnes (A:Z), j'ai bien essayé de changer les colonnes dans les paramètres pour que ca copie toutes les colonnes jusqu'à QOD mais cela devient trop lent et ca plante à chaque fois, quelque soit la taille des fichiers.

Pensez-vous donc qu'il serait possible de simplifier cette macro en gardant les fonctionnalités (choisir mes fichiers avec une boite de dialogue, créer un nouveau fichier et pouvoir choisir le nom de ce nouveau fichier)? Ou bien essayer avec une autre méthode..?

Voici mon code actuel:

Private Sub CommandButton1_Click()
Dim Wb As Workbook
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Filters.Add Description:="Microsoft Excel", Extensions:="*.xls;*.xlsx;*.xlsm", Position:=1
.Show
If .SelectedItems.Count > 0 Then
cheminfichier = .SelectedItems(1)
For k = 1 To .SelectedItems.Count
ListBox1.AddItem .SelectedItems(k)
Next
End If
End With
End Sub

Private Sub CommandButton2_Click()
On Error Resume Next
bas = 1
Feuil2.Cells.ClearContents
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For k = 0 To ListBox1.ListCount - 1
bas = Feuil2.[A:Z].Find("*", , , , 1, 2).Row + 1

'bas = Feuil2.Cells.Find("*", [A1], , , 1, 2).Row + 1
Set Wb = GetObject(ListBox1.List(k))
If k = 0 Then
Wb.Sheets(1).[A1:Z1500].Copy
Elsea
Wb.Sheets(1).[A5:Z1500].Copy
End If
Feuil2.Range("A" & bas).PasteSpecial 'xlPasteValues
Wb.Close
Next
fichier = InputBox("Entrer le nom du fichier sans l'extansion !", "NOM FICHIER", "Recap")
If fichier <> "" Then
chemin = ThisWorkbook.Path & "\" & fichier & ".xlsx"
Feuil2.Copy
On Error Resume Next
Sheets(1).SaveAs ThisWorkbook.Path & "\" & fichier & ".xlsx"
Workbooks(fichier & ".xlsx").Close
Application.DisplayAlerts = True
ThisWorkbook.Activate
Feuil2.Cells.ClearContents
Application.ScreenUpdating = True
End If
Unload UserForm1
End Sub

 

[Dranreb]

Re : Améliorer une macro pour fusion de fichiers

Bonjour.

Essayez peut être comme ça :

Dim Wb As Workbook, Src as Range, Cbl As Range, L As Long
…
Set Cbl = Feui2.[A1]
For L = 0 To ListBox1.ListCount - 1
    Set Wb = GetObject(ListBox1.List(L))
    Set Src = Wb.Sheets(1).UsedRange
    Cbl.Resize(Src.Rows.Count, Src.Columns.Count).Value = Src.Value
    Set Cbl = Cbl.Offset(Src.Rows.Count)
    Wb.Close
    Next L

 

[samo.m]

Re : Améliorer une macro pour fusion de fichiers

Bonjour Dranreb,

Merci pour votre réponse!
Pouvez vous me mettre votre code à l'emplacement requis dans mon code car je ne vois pas exactement ou le placer ( je pense avoir une ou deux ligne de décalage lorsque j'essaie).

Cordialement

 

[Dranreb]

Re : Améliorer une macro pour fusion de fichiers

Après le Application.ScreenUpdating = False, en remplacement de la boucle For K
Les déclarations, elles se mettent généralement au début de la procédure.
Ah j'ai enfin compris à quoi sert le test If K = 0. J'ai mis le temps.
Alors il faut ajouter derrière le Set Src = :

If L>0 Then Set Src = Src.Rows(5).Resize(Src.Rows.Count - 4)

 

[samo.m]

Re : Améliorer une macro pour fusion de fichiers

Merci Dranreb!

J'ai essayé en modifiant le code:

J'ai donc celui-ci actuellement

Private Sub CommandButton1_Click()
Dim Wb As Workbook, Src As Range, Cbl As Range, L As Long
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Filters.Add Description:="Microsoft Excel", Extensions:="*.xls;*.xlsx;*.xlsm", Position:=1
.Show
If .SelectedItems.Count > 0 Then
cheminfichier = .SelectedItems(1)
For k = 1 To .SelectedItems.Count
ListBox1.AddItem .SelectedItems(k)
Next
End If
End With
End Sub

Private Sub CommandButton2_Click()
On Error Resume Next
bas = 1
Feuil2.Cells.ClearContents
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set Cbl = Feui2.[A1]
For L = 0 To ListBox1.ListCount - 1
    Set Wb = GetObject(ListBox1.List(L))
    Set Src = Wb.Sheets(1).UsedRange
    If L > 0 Then Set Src = Src.Rows(5).Resize(Src.Rows.Count - 4)
    Cbl.Resize(Src.Rows.Count, Src.Columns.Count).Value = Src.Value
    Set Cbl = Cbl.Offset(Src.Rows.Count)
    Wb.Close
    Next L
fichier = InputBox("Entrer le nom du fichier sans l'extansion !", "NOM FICHIER", "Recap")
If fichier <> "" Then
chemin = ThisWorkbook.Path & "\" & fichier & ".xlsx"
Feuil2.Copy
On Error Resume Next
Sheets(1).SaveAs ThisWorkbook.Path & "\" & fichier & ".xlsx"
Workbooks(fichier & ".xlsx").Close
Application.DisplayAlerts = True
ThisWorkbook.Activate
Feuil2.Cells.ClearContents
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End If
Unload UserForm1
End Sub

Le problème est que cette macro me crée un fichier sans aucune donnée...

 

[Dranreb]

Re : Améliorer une macro pour fusion de fichiers

La déclaration doit être dans la Sub CommandButton2_Click() pas la CommandButton1_Click()

 

[samo.m]

Re : Améliorer une macro pour fusion de fichiers

Merci Dranreb mais cela ne fonctionne toujours pas...
Le nouveau fichier ne contient aucune donnée

 

[Dranreb]

Re : Améliorer une macro pour fusion de fichiers

Déroulez en pas à pas, mettez des espions. Ça devrait marcher.
Remarquez j'utilise Set Wb = Workbooks.Open(etc. Je n'ai pas l'habitude de GetObject, je ne sais pas s'il y a des différences.