Discussion :

[kiki29]

Cet utilitaire permet de faire l'inverse du Découpage d'un fichier Excel CSV

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

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
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
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")
    bEntete = ShParam.CheckBoxes("chkEntete").Value = 1
 
    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.Range("B" & Rows.Count).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, Local:=True)
            With WkbDecoupage.Worksheets(1)
                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
                WkbDecoupage.Close SaveChanges:=False
            End With
            Set WkbDecoupage = Nothing
            Application.StatusBar = i - RDepart + 1 & " / " & iLast - RDepart + 1
        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
    WkbFusion.SaveAs sNouveauNom
    WkbFusion.Close
    Set WkbFusion = Nothing
 
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    With ShParam
        .Select
        .Range("B2").Select
    End With
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = Application.StatusBar & " / Terminé : " & Format(((Fin - Dep) / Freq), "0.000 s")
End Sub