Discussion :

[kiki29]

Permet la fusion des feuilles de même nom de x fichiers xls et génère un fichier de cette fusion dans un dossier créé à la racine de l'appli.

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 (2)

[boulifard]

bonjour,

j'ai du mal à utiliser cette routine car je ne sais pas la mettre en œuvre…

pouvez-vous m'aider ?

merci

jb

[kiki29]

Salut, il y a aussi : Fusion de fichiers Excel XLS (3). Les principes de base restant les mêmes.

Pour un mode d'emploi va voir sur ce post.

[boulifard]

bonjour,

et chapeau pour la rapidité de votre réponse !

mais je ne sais toujours pas si la routine doit-être activée avec visual basic ?

encore merci pour votre aide

jb

[kiki29]

mais je ne sais toujours pas si la routine doit-être activée avec visual basic ?

????? Cette appli fonctionne via Excel en VBA. Elle est composée de procédures et fonctions ... Lis le mode d'emploi !
Je ne comprends pas ta demande.