Discussion :

[kiki29]

Fusion de fichiers Excel XLS

Permet de faire l'inverse de : Découpage d'un fichier Excel (3)

Extrait :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
Sub FusionFichiers()
Dim i As Long, iEntete As Long, bFirst As Boolean, bEntete As Boolean
Dim iLast As Long, iLastRow As Long, iLastCol As Long, bVide As Boolean, FSO As Object
Dim WkbFusion As Workbook, WkbDecoupage As Workbook, bDoublons As Boolean, sFeuille As String
Dim sDossier As String, sNomDossier As String, sDossierDecoupage As String, sPre As String, sNouveauNom As String
 
    QueryPerformanceCounter Dep
 
    Application.StatusBar = ""
    DecompteA
 
    sDossierDecoupage = ShParam.Range("A1")
 
    bVide = ShParam.CheckBoxes("chkVider").Value = 1
    bDoublons = ShParam.CheckBoxes("chkDoublons").Value = 1
    If bVide Then
        ShParam.CheckBoxes("chkDoublons").Value = 0
        bDoublons = False
    End If
    If Cpt = 0 Then
        MsgBox "Taper dans la colonne A un x ou X en vis à vis" & vbCrLf & _
               "des fichiers à Fusionner de la colonne B", vbInformation + vbOKOnly, "x ou X"
        Exit Sub
    End If
 
    sNomDossier = ShParam.Range("D7")
    sPre = ShParam.Range("D8")
    iEntete = ShParam.Range("D9")
    sFeuille = ShParam.Range("D10")
    bEntete = ShParam.CheckBoxes("chkEntete").Value = 1
    Cpt = 0
    If iEntete = 0 Then ShParam.CheckBoxes("chkEntete").Value = 0: bEntete = False
 
    sDossier = ThisWorkbook.Path & "\" & sNomDossier
    If bVide Then
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FolderExists(sDossier) Then FSO.DeleteFolder sDossier, True
        Set FSO = Nothing
    End If
 
    CreationDossier sDossier
 
    Application.ScreenUpdating = False
    bFirst = True
    iLast = ShParam.Cells(Rows.Count, "B").End(xlUp).Row
 
    If bFirst Then
        Set WkbFusion = Workbooks.Add
    End If
 
    For i = RDepart To iLast
        If UCase$(ShParam.Range("A" & i)) = "X" Then
            Set WkbDecoupage = Workbooks.Open(Filename:=sDossierDecoupage & "\" & ShParam.Range("B" & i), ReadOnly:=True)
            If FeuilleExiste(WkbDecoupage.Name, sFeuille) Then
                With WkbDecoupage.Worksheets(sFeuille)
                    If FeuilleVide(WkbDecoupage.Worksheets(sFeuille)) = False Then
                        iLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                        iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                        If bEntete Then
                            .Range("A1:A" & iEntete).Resize(, iLastCol).Copy WkbFusion.Worksheets(1).Range("A1")
                            .Range(.Cells(iEntete + 1, "A"), .Cells(iLastRow, iLastCol)).Copy _
                                    WkbFusion.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1)
                        Else
                            .Range(.Cells(iEntete + 1, "A"), .Cells(iLastRow, iLastCol)).Copy _
                                    WkbFusion.Worksheets(1).Cells(Rows.Count, "A").End(xlUp)
                        End If
                    Else
                        ShParam.Range("A" & i) = "o"
                    End If
                    WkbDecoupage.Close SaveChanges:=False
                End With
                Cpt = Cpt + 1
                Application.StatusBar = Cpt & " / " & iLast - RDepart + 1
            Else
                ShParam.Range("A" & i) = ""
                WkbDecoupage.Close SaveChanges:=False
            End If
            Set WkbDecoupage = Nothing
        End If
    Next i
 
    WkbFusion.Worksheets(1).Columns.AutoFit
    If bDoublons Then
        sNouveauNom = RenommerFichier(sDossier, sPre & ".xls")
    Else
        sNouveauNom = sDossier & "\" & sPre & ".xls"
    End If
 
    Application.DisplayAlerts = False
    If bEntete Then
        EnteteClasseurTempo iEntete, WkbFusion
    Else
        EnteteClasseurTempoNo WkbFusion
    End If
 
    If FeuilleVide(WkbFusion.Worksheets(1)) = False Then
        WkbFusion.SaveAs sNouveauNom
        WkbFusion.Close SaveChanges:=False
    Else
        WkbFusion.Close SaveChanges:=False
    End If
    Set WkbFusion = Nothing
 
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    With ShParam
        .Activate
        .Range("B2").Select
    End With
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = Application.StatusBar & " / Terminé : " & Format(((Fin - Dep) / Freq), "0.000 s")
End Sub

Téléchargeable ici : Fusion de fichiers Excel XLS