Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Améliorer une macro pour fusion de fichiers

S

samo.m

XLDnaute Nouveau
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:

Code: 
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
 
Trier par date Trier par votes

Dranreb

XLDnaute Barbatruc
Re : Améliorer une macro pour fusion de fichiers

Bonjour.

Essayez peut être comme ça :
VB: 
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
 
Vote positif 0 Vote négatif
S

samo.m

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif

Dranreb

XLDnaute Barbatruc
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 = :
VB: 
If L>0 Then Set Src = Src.Rows(5).Resize(Src.Rows.Count - 4)
 
Dernière édition:
Vote positif 0 Vote négatif
S

samo.m

XLDnaute Nouveau
Re : Améliorer une macro pour fusion de fichiers

Merci Dranreb!

J'ai essayé en modifiant le code:

J'ai donc celui-ci actuellement

Code: 
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...
 
Vote positif 0 Vote négatif

Dranreb

XLDnaute Barbatruc
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.
 
Dernière édition:
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

P
  • Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
483
job75
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
372
CathyLD
C
N
  • Résolu(e)
Microsoft 365 Format date d'une textbox vers une cellule
Réponses
8
Affichages
564
ChTi160
U
  • Question
Autres incorporer une macro dans une autre macro
Réponses
5
Affichages
328
Phil69970
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
528
AtTheOne
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
2 K
saidoush
S
C
  • Résolu(e)
XL 2019 Importer fichier csv sans consatener les colonnes
2 3
Réponses
34
Affichages
2 K
laurent950
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
457
GClaire
G
S
  • Question
XL 2016 Macro pour convertir .PDF en .XLSX
3 4 5
Réponses
62
Affichages
3 K
Staple1600
N
  • Question
XL 2016 Macro chargement liste arborescence, copier coller fichiers
Réponses
9
Affichages
605
Nermal64
N
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…