Discussion :

[manu900]

Bonjour à tous,

Je vous sollicite car je n'arrive pas à réaliser l'opérations que je souhaite. Explication :

J'ai un fichier qui s'apelle Test contenant 3 feuilles :
. Sur ces 3 feuilles, la première ligne est identique pour chacune d'elles.
. Contenu différent.
. Certaines cellules des 3 premières colonnes sont fusionnées.

Je souhaiterai copier le contenu des trois feuilles (jusqu'a la dernière cellule de la colonne B) vers une seule feuille dans autre classeur.
De plus lorsque le copier/coller des feuilles est terminé, je souhaite appliquer la fonction unmerge sur les cellules fusionner et copié le contenu des cellules qui était fusionné.

Voilà mon code, simplement c'est qu'il y a une erreur et je n'arrive pas à trouver la solution :

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
Sub Copier()
 
Dim LastLig As Long
 
With Workbooks("Test.xlsm")
 
Var_Chemin = "C:\CopieTest.xlsx"
fichier1 = ActiveWorkbook.Name
Workbooks.Open Var_Chemin, 0, ReadOnly:=False
Fichier2 = ActiveWorkbook.Name
LastLig = Worksheets.Cells(.Rows.Count, "B").End(xlUp).Row
 
For lngCount = 1 To Workbooks(fichier1).Worksheets.Count
 
 
Workbooks(fichier1).Sheets(lngCount).Range("A1:E" & LastLig)Copy Before:=Workbooks(Fichier2).Sheets("Feuil1")
 
Next
End With
End Sub

Voici également les fichiers:Test.xlsx
CopieTest.xlsx.

J'èspere avoir été précis, en tout cas je vous remercie d'avance pour vos réponse.

Bonne journée.

[Daniel.C]

Bonjour,

La syntaxe de cette ligne :

Code :

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

Workbooks(fichier1).Sheets(lngCount).Range("A1:E" & LastLig)Copy Before:=Workbooks(Fichier2).Sheets("Feuil1")

sert à copier une feuille de plus, il faut un point avant "Copy". Si c'est le cas, il faut enlever :

Code :

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

Range("A1:E" & LastLig)

En effet, c'est toute la feuille que tu copies, y compris les éventuelles macros.

[mercatog]

Quelque chose comme ceci (copie de toutes les feuilles du fichier contenant la macro vers le fichier CopieTest)

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
Sub Copier()
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
 
Application.ScreenUpdating = False
Chemin = "C:\CopieTest.xlsx"
If Dir(Chemin) <> "" Then
    Set Wbk = Workbooks.Open(Filename:=Chemin, UpdateLinks:=False)
    For Each Ws In ThisWorkbook.Worksheets
        Ws.Copy Before:=Wbk.Worksheets("Feuil1")
    Next Ws
    Wbk.Close True
    Set Wbk = Nothing
    MsgBox "Copie terminée"
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub

[manu900]

Bonjour Daniel et Mercatog

Merci pour vos réponses.
En effet, vos solutions fonctionne.

Cependant, j'aimerais juste copier tous le contenus des 3 feuilles dans une seule feuille qui se trouve sur autre classeur. C'est à dire mettre les tableaux à la suite des autres dans une unique feuille.

Cordialement.

[Daniel.C]

Essaie :

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
Sub Copier()
 
Dim LastLig As Long, Ligne As Long
 
With Workbooks("Test.xlsm")
 
Var_Chemin = "C:\CopieTest.xlsx"
fichier1 = ActiveWorkbook.Name
Workbooks.Open Var_Chemin, 0, ReadOnly:=False
Fichier2 = ActiveWorkbook.Name
Ligne = 1
For lngCount = 1 To Workbooks(fichier1).Worksheets.Count
 
LastLig = Worksheets.Cells(.Rows.Count, "B").End(xlUp).Row
Workbooks(fichier1).Sheets(lngCount).Range("A1:E" & LastLig).Copy Workbooks(Fichier2).Sheets("Feuil1").Cells(Ligne, 1)
Ligne = Workbooks(Fichier2).Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row + 1
 
Next
End With
End Sub

[mercatog]

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
Sub Copier()
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim NewLig As Long
 
Application.ScreenUpdating = False
Chemin = "C:\CopieTest.xlsx"
If Dir(Chemin) <> "" Then
    Set Wbk = Workbooks.Open(Filename:=Chemin, UpdateLinks:=False)
    With Wbk.Worksheets(1)
        For Each Ws In ThisWorkbook.Worksheets
            NewLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            Ws.UsedRange.Copy .Range("A" & NewLig)
        Next Ws
    End With
    Wbk.Close True
    Set Wbk = Nothing
    MsgBox "Copie terminée"
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub

[manu900]

Après de multiples essaies, le code se bloque pour les deux méthodes (Daniel et Mercatog) au même niveau :

Code :

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

1
2
LastLig = Worksheets.Cells(.Rows.Count, "B").End(xlUp).Row
NewLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

Merci à vous deux.

[Daniel.C]

Ce n'est pas ce que j'ai écrit :

Code :

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

Ligne = Workbooks(Fichier2).Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row + 1

Tu pourrais aussi dire quel est le message d'erreur.

[manu900]

Excusez moi, j'ai du faire une erreur précédemment. Effectivement Mercatog ton code fonctionne.

Par contre saurais-tu comment faire pour prendre en compte toutes les feuilles sauf la feuille 1 car toi tu as utilisé la fonction "for each".

Si par la même occasion tu pourrais m'indiquer par quelle moyen on enlève la fusion des cellules et copie les données sur celle ou il n'y a rien.

Merci Encore

[mercatog]

Je n'ai pas compris la 2ème question, néanmoins pour supprimer la fusion on utilise Unmerge et pour ne pas tenit en compte Feuil1, on ajoute une condition sur le nom de la feuille Ws

Exemple

Code :

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

1
2
3
4
5
6
7
8
9
10
    With Wbk.Worksheets(1)
        For Each Ws In ThisWorkbook.Worksheets
            If Ws.Name <> "Feuil1" Then
                NewLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                'enlève la fusion
                Ws.UsedRange.UnMerge
                Ws.UsedRange.Copy .Range("A" & NewLig)
            End If
        Next Ws
    End With

[manu900]

C'est à dire que lorsque tu des-fractionne une plage de cellule,par la suite une seule cellule va contenir les données qui été inscrit sur la plage.

Je souhaite que toutes les cellules une fois des-fractionner contiennent les données.
Exemple :
. Départ :Les cellules "A1:A3" sont fusionnés et contiennent le mot "vba"
. usedrange.unmerge
. ......
. Arrivée : la Cellule A1, A2 et A3 contiennent à présent le mot "vba"

Merci pour Mercatog.

[mercatog]

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
Sub Copier()
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim NewLig As Long
 
Application.ScreenUpdating = False
Chemin = "C:\CopieTest.xlsx"
If Dir(Chemin) <> "" Then
    Set Wbk = Workbooks.Open(Filename:=Chemin, UpdateLinks:=False)
    With Wbk.Worksheets(1)
        For Each Ws In ThisWorkbook.Worksheets
            If Ws.Name <> "Feuil1" Then
                NewLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                'enlève la fusion
                Fractionne Ws
                Ws.UsedRange.Copy .Range("A" & NewLig)
            End If
        Next Ws
    End With
    Wbk.Close True
    Set Wbk = Nothing
    MsgBox "Copie terminée"
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub
 
Private Sub Fractionne(Ws As Worksheet)
Dim c As Range
 
For Each c In Ws.UsedRange
    If c.MergeCells Then
        With c.MergeArea
            .UnMerge
            .Value = .Cells(1, 1).Value
        End With
    End If
Next c
End Sub

[manu900]

C'est exactement l'opération que je souhaite , simplement je ne veux pas modifier le fichier worksheet (Test) mais que l'opération soit réaliser simplement sur le workbook (CopieTest). J'ai essayer de modifier le code, il m'indique une erreur d'exécution '438' ; propriété ou méthode non géré par cette objet.

code:

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
Sub Copier()
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim NewLig As Long
 
Application.ScreenUpdating = False
Chemin = "C:\CopieTest.xlsx"
If Dir(Chemin) <> "" Then
    Set Wbk = Workbooks.Open(Filename:=Chemin, UpdateLinks:=False)
    With Wbk.Worksheets(1)
        For Each Ws In ThisWorkbook.Worksheets
            If Ws.Name <> "1" Then
                NewLig = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
 
                Ws.UsedRange.Copy .Range("A" & NewLig)
                'enlève la fusion
                Fractionne Wbk
        End If
        Next Ws
    End With
    'Wbk.Close True
    Set Wbk = Nothing
    MsgBox "Copie terminée"
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Fractionne(Wbk As Workbook)
 
Dim c As Range
 
For Each c In Wbk.UsedRange 'erreur qui s'affiche sur cette ligne
    If c.MergeCells Then
        With c.MergeArea
            .UnMerge
            .Value = .Cells(1, 1).Value
        End With
    End If
Next c
End Sub

Merci, et bonne soirée

[mercatog]

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
Sub Copier()
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim NewLig As Long
 
Application.ScreenUpdating = False
Chemin = "C:\CopieTest.xlsx"
If Dir(Chemin) <> "" Then
    Set Wbk = Workbooks.Open(Filename:=Chemin, UpdateLinks:=False)
    With Wbk.Worksheets(1)
        For Each Ws In ThisWorkbook.Worksheets
            If Ws.Name <> "Feuil1" Then
                NewLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                Ws.UsedRange.Copy .Range("A" & NewLig)
            End If
        Next Ws
    End With
    'enlève la fusion
    Fractionne Wbk.Worksheets(1)
    Wbk.Close True
    Set Wbk = Nothing
    MsgBox "Copie terminée"
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub
 
Private Sub Fractionne(Ws As Worksheet)
Dim c As Range
 
Application.ScreenUpdating = False
For Each c In Ws.UsedRange
    If c.MergeCells Then
        With c.MergeArea
            .UnMerge
            .Value = .Cells(1, 1).Value
        End With
    End If
Next c
End Sub

[manu900]

Bonjour Mercatog,

Tout fonctionne à la perfection, merci pour tout.