Discussion :

[Korteby]

Bonjour,

J'ai un problème avec ce code de concaténation : je dois dé-fusionner les cellules d'une plage mais lors de la copie de celle-ci, seule la cellule A1 est copiée correctement et je n'arrive pas à récupérer l'intégralité des cellules...

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
Sub Compilation()
Dim Temp As String
Dim Ligne As Long
Temp = Dir(ActiveWorkbook.Path & "\*.xls")
Application.DisplayAlerts = False
Do While Temp <> ""
If Temp <> "Recap.xls" Then
Workbooks.Open ActiveWorkbook.Path & "\" & Temp
 
Range("A1:N36").Select
    With Selection
        .MergeCells = False
    End With
 
Workbooks(Temp).Sheets(1).Range("A1:N36").CurrentRegion.Copy
 
Workbooks("Recap.xls").Sheets(1).Activate
 
Ligne = Sheets(1).Range("A65536").End(xlUp).Row + 1
 
Range("A" & CStr(Ligne)).Select
 
ActiveSheet.Paste
Workbooks(Temp).Close
End If
Temp = Dir
Loop
Range("A1").Select
Application.DisplayAlerts = True
End Sub

[titou31000]

Tu n'as pas quelque chose du style

Code :

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

Selection.UnMerge

[Daranc]

pas trop compris ce que tu demandes
est ce ceci

Code :

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

1
2
3
4
5
Workbooks("Recap.xls").Sheets(1).Activate
 
Ligne = Sheets(1).Range("A65536").End(xlUp).Row + 1
 
Range("A" & ligne &":N" & ligne+36).Select

[Korteby]

En fait, ce programme concatène de nombreux fichiers XL en un seul....Seulement, les fichiers possèdent des cellules fusionnées et je n'arrive pas à résoudre le problème.

[Korteby]

En fait j'ai récupéré ce code Extract.xls qui concatène plusieurs fichers XL :

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
Sub Compilation()
Dim Temp As String
Dim Ligne As Long
Temp = Dir(ActiveWorkbook.Path & "\*.xls")
Application.DisplayAlerts = False
Do While Temp <> ""
If Temp <> "Recap.xls" Then
Workbooks.Open ActiveWorkbook.Path & "\" & Temp
Workbooks(Temp).Sheets(1).Range("A1").CurrentRegion.Copy
Workbooks("Recap.xls").Sheets(1).Activate
Ligne = Sheets(1).Range("A65536").End(xlUp).Row + 1
Range("A" & CStr(Ligne)).Select
 
ActiveSheet.Paste
Workbooks(Temp).Close
End If
Temp = Dir
Loop
Range("A1").Select
Application.DisplayAlerts = True
End Sub

ça marche très bien sauf pour les fichiers possédant des cellules fusionnées!
Je voudrais donc l'adapter.

Merci d'avance

[mercatog]

Les cellules fusionnées sont dans le classeur source ou le classeur destination?

Sinon, à propos du #5?

[Korteby]

Merci beaucoup de ta réponse mais....ça ne fonctionne pas mieux.

J'ai joint l'un des fichier source.

Les cellules fusionnées sont dans le fichier source.

[mercatog]

Si les cellules fusionnées sont dans les fichiers sources, pas besoin de les dé-fusionner avant copie

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
Sub Compilation()
Dim Wbk As Workbook
Dim Temp As String
Dim Ligne As Long
 
Temp = Dir(ThisWorkbook.Path & "\*.xls")
Do While Temp <> ""
    If Temp <> ThisWorkbook.Name Then
        With ThisWorkbook.Worksheets(1)
            Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With
 
        Set Wbk = Workbooks.Open(ThisWorkbook.Path & "\" & Temp)
 
        Wbk.Worksheets(1).Range("A1:N36").Copy ThisWorkbook.Worksheets(1).Range("A" & Ligne)
 
        Wbk.Close False
        Set Wbk = Nothing
    End If
    Temp = Dir
Loop
End Sub

[mercatog]

Essaies comme ceci

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
Sub Compilation()
Dim Wbk As Workbook
Dim Temp As String
Dim Ligne As Long
 
Temp = Dir(ThisWorkbook.Path & "\*.xls")
Do While Temp <> ""
    If Temp <> "Recap.xls" Then
        With ThisWorkbook.Worksheets(1)
            Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With
 
        Set Wbk = Workbooks.Open(ThisWorkbook.Path & "\" & Temp)
 
        With Wbk.Worksheets(1).Range("A1:N36").CurrentRegion
            .UnMerge
            .Copy ThisWorkbook.Worksheets(1).Range("A" & Ligne)
        End With
 
        Wbk.Close False
        Set Wbk = Nothing
    End If
    Temp = Dir
Loop
End Sub