Deplacer/copier dans un nouveau classeur [Résolu]

[blanka347]

Bonjour à tous,

J'ai un petit souci avec une macro,

Alors quelques petites explications :

J'ai un classeur avec beaucoup de feuilles. Ce classeur je doit l' "eclater" en deux classeurs.

Exemple :

Un classeur1 avec les feuilles A, B, C, D, E, F, G, H.

Puis créer un classeur2 avec les feuille B, C, H
Puis créer un classeur3 avec les autres feuilles.
Sachant que je veux faire uniquement une copie en valeur avec le même format.

Et enregistrer les deux nouveaux classeurs avec l'adresse et le nom de mon choix.

J'ai essayé de faire avec l'enregistreur de macro mais il s'arrête à la copie des feuilles.

P.S : Mon fichier est vraiment trés lourd avec beaucoup de formule.

Voilà j'espere que j'ai été clair,

Merci

[jfontaine]

Bonjour,

Ci dessous une solution. dis nous si ok

Code :

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
Sub Export()
 
Dim Wrk1 As Workbook 'Feuille B C H
Dim Wrk2 As Workbook 'Autres Feuilles
 
Dim Sh As Worksheet
 
Set Wrk1 = Application.Workbooks.Add
Set Wrk2 = Application.Workbooks.Add
 
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
 
'Boucle sur les feuilles du classeur
For Each Sh In ThisWorkbook.Worksheets
 
    Select Case Sh.Name
        Case "B", "C","H"
            'Copie dans le Classeur 1
            Sh.Copy before:=Wrk1.Sheets(1)
            Wrk1.Sheets(1).Cells.Copy
            Wrk1.Sheets(1).Cells.PasteSpecial xlPasteValues
 
        Case else
            Sh.Copy before:=Wrk2.Sheets(1)
            Wrk2.Sheets(1).Cells.Copy
            Wrk2.Sheets(1).Cells.PasteSpecial xlPasteValues
 
    End Select
 
Next
 
Wrk1.SaveAs Filename:=ThisWorkbook.Path & "\Save BHC.xls"
Wrk2.SaveAs Filename:=ThisWorkbook.Path & "\Save AUTRES.xls"
 
Wrk1.Close False
Wrk2.Close False
 
Set Wrk1 = Nothing
Set Wrk2 = Nothing
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 
End Sub

[blanka347]

Salut jfontaine,

Merci de ta réponse,

Alors effectivement ça marche très bien, par contre j'ai omis quelques détails dans mon énoncé je pensais pas que ça changerait quelque chose mais apparemment si...

Alors en fait ta macro gère parfaitement jusqu'à ce que tu lui demandes "d'exporter" une même feuille dans les deux classeurs. Si je reprends mon exemple : Je souhaiterais avoir la feuille "A" dans les deux nouveaux classeurs.

Second problème arrive à l'enregistrement mais là, je pense que le problème est entre mon fauteuil et mon ordinateur ^^ Ca je pense que je pourrais résoudre seul.

Et enfin tu pourrais m'en dire un peu plus sur la fonction "Select case" ?

Merci beaucoup.

Edit : Le code modifié

Code :

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
Sub Export()
 
Dim Wrk1 As Workbook 'Feuille B C H
Dim Wrk2 As Workbook 'Autres Feuilles
 
Dim Sh As Worksheet
 
Set Wrk1 = Application.Workbooks.Add
Set Wrk2 = Application.Workbooks.Add
 
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
 
'Boucle sur les feuilles du classeur
For Each Sh In ThisWorkbook.Worksheets
 
    Select Case Sh.Name
        Case "B", "C","H"
            'Copie dans le Classeur 1
            Sh.Copy before:=Wrk1.Sheets(1)
            Wrk1.Sheets(1).Cells.Copy
            Wrk1.Sheets(1).Cells.PasteSpecial xlPasteValues
 
        Case "B", "A", "G"
            Sh.Copy before:=Wrk2.Sheets(1)
            Wrk2.Sheets(1).Cells.Copy
            Wrk2.Sheets(1).Cells.PasteSpecial xlPasteValues
 
    End Select
 
Next
 
Wrk1.SaveAs Filename:=ThisWorkbook.Path & "\Save BHC.xls"
Wrk2.SaveAs Filename:=ThisWorkbook.Path & "\Save AUTRES.xls"
 
Wrk1.Close False
Wrk2.Close False
 
Set Wrk1 = Nothing
Set Wrk2 = Nothing
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 
End Sub

[jfontaine]

Le premier case prend les feuilles communes aux 2 classeurs
Le deuxieme case les feuilles a mettre dans le classeur 1
Le troisième, les feuilles a mettre dans le classeur 2

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
    Select Case Sh.Name
        Case "B"
            Sh.Copy before:=Wrk1.Sheets(1)
            Wrk1.Sheets(1).Cells.Copy
            Wrk1.Sheets(1).Cells.PasteSpecial xlPasteValues
 
            Sh.Copy before:=Wrk2.Sheets(1)
            Wrk2.Sheets(1).Cells.Copy
            Wrk2.Sheets(1).Cells.PasteSpecial xlPasteValues
 
        Case "C","H"
            Sh.Copy before:=Wrk1.Sheets(1)
            Wrk1.Sheets(1).Cells.Copy
            Wrk1.Sheets(1).Cells.PasteSpecial xlPasteValues
 
        Case "A", "G"
            Sh.Copy before:=Wrk2.Sheets(1)
            Wrk2.Sheets(1).Cells.Copy
            Wrk2.Sheets(1).Cells.PasteSpecial xlPasteValues
 
    End Select

[blanka347]

Ok je pense que je pourrais m'en sortir maintenant. En tous les cas merci beaucoup, code très pertinent avec la gestion des fichiers lourd! Calcul manuel, actualisation de l'ecran, etc... Un grand merci.

Je rajoute quelques commentaires dans le code pour ceux qui voudrais le reprendre.

Code :

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
 
 
Sub Export()
 
Dim Wrk1 As Workbook 'Feuille B C H
Dim Wrk2 As Workbook 'Autres Feuilles
Dim Sh As Worksheet
 
'création des nouveaux classeurs
Set Wrk1 = Application.Workbooks.Add
Set Wrk2 = Application.Workbooks.Add
 
'désactive le calcul automatique
Application.Calculation = xlCalculationManual
'désactive le rafraîchissement de l'écran (améliore le temps de calcul) 
Application.ScreenUpdating = False
 
'Boucle sur les feuilles du classeur
For Each Sh In ThisWorkbook.Worksheets
  Select Case Sh.Name
        Case "B"
'Copie la feuille dans le Wrk1 et Wrk2 en même temps, si la feuille doit etre copier dans plusieurs classeurs
            Sh.Copy before:=Wrk1.Sheets(1)
            Wrk1.Sheets(1).Cells.Copy
            Wrk1.Sheets(1).Cells.PasteSpecial xlPasteValues
 
            Sh.Copy before:=Wrk2.Sheets(1)
            Wrk2.Sheets(1).Cells.Copy
            Wrk2.Sheets(1).Cells.PasteSpecial xlPasteValues
 'copie les autres feuilles (attention à l'ordre des feuilles)
        Case "C","H"
            Sh.Copy before:=Wrk1.Sheets(1)
            Wrk1.Sheets(1).Cells.Copy
            Wrk1.Sheets(1).Cells.PasteSpecial xlPasteValues
 
        Case "A", "G"
            Sh.Copy before:=Wrk2.Sheets(1)
            Wrk2.Sheets(1).Cells.Copy
            Wrk2.Sheets(1).Cells.PasteSpecial xlPasteValues
 
    End Select
Next
 
Wrk1.SaveAs Filename:=ThisWorkbook.Path & "\Save BHC.xlsx"
Wrk2.SaveAs Filename:=ThisWorkbook.Path & "\Save AUTRES.xlsx"
'Wrk2.SaveAs Filename:"\adresse du fichier si différent du classeur d'origine"
 
Wrk1.Close False
Wrk2.Close False
 
Set Wrk1 = Nothing
Set Wrk2 = Nothing
 
'Active le calcul automatique
Application.Calculation = xlCalculationAutomatic
'Active le rafraîchissement de l'écran 
Application.ScreenUpdating = True
 
End Sub

[blanka347]

Je reviens poster ici car j'ai quelques soucis avec cette macro :s

En fait à la fin de la macro je foudrais réorganiser mes feuilles et les mettre dans un ordre spécifique donc j'ai fais ca mais ca marche pas du tout !

Voici le code aprés le "Next" :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Next
 
' L'ordre que je souhaite c E, D, C, B, A, G.
 
Wrk1.Sheets("A").Move before:=Sheets("G")
Wrk1.Sheets("B").Move before:=Sheets("G")
Wrk1.Sheets("C").Move before:=Sheets("G")
Wrk1.Sheets("D").Move before:=Sheets("G")
Wrk1.Sheets("E").Move before:=Sheets("G")
 
'suppression des feuilles de base dans le classeur
 
Wrk1.Sheets("Feuil1").Delete
Wrk1.Sheets("Feuil2").Delete
Wrk1.Sheets("Feuil3").Delete
 
Wrk2.Sheets("A").Move before:=Sheets("H")
Wrk2.Sheets("B").Move before:=Sheets("H")
Wrk2.Sheets("C").Move before:=Sheets("H")
 
Wrk2.Sheets("Feuil1").Delete
Wrk2.Sheets("Feuil2").Delete
Wrk2.Sheets("Feuil3").Delete

Il se melange les pinceaux entre les deux classeurs :s
Il faudrais rajouter une ligne pour dire "fais ça ici, puis ça la bas" un truc du genre ^^

Des idées merci !

Bonne journée

[jfontaine]

Quelques modifs

- Créer les classeurs wrk1 et wrk2 avec une seule feuille

Code :

1
2
Set Wrk1 = Application.Workbooks.Add(xlWBATWorksheet)
Set Wrk2 = Application.Workbooks.Add(xlWBATWorksheet)

-Copier les feuilles après la dernière feuille (classement dans le même ordre que le classeur origine)

Code :

Sh.Copy after:=Wrk1.Sheets(Wrk1.Sheets.Count)

- Suppression de la feuil1

Code :

Wrk1.Sheets("Feuil1").Delete

- Désactivation des messages d'alerte (a réactiver en fin de macro)

Code :

1
2
3
Application.DisplayAlerts = False
....
Application.DisplayAlerts = True

Code complet

Code :

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
Sub Export()
 
Dim Wrk1 As Workbook 'Feuille A B C
Dim Wrk2 As Workbook 'Feuille A B
 
Dim Sh As Worksheet
 
Application.DisplayAlerts = False
 
Set Wrk1 = Application.Workbooks.Add(xlWBATWorksheet)
Set Wrk2 = Application.Workbooks.Add(xlWBATWorksheet)
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
 
'Boucle sur les feuilles du classeur
For Each Sh In ThisWorkbook.Worksheets
 
    Select Case Sh.Name
        Case "B", "C"
            'Copie dans le Classeur 1
            Sh.Copy after:=Wrk1.Sheets(Wrk1.Sheets.Count)
            Wrk1.Sheets(1).Cells.Copy
            Wrk1.Sheets(1).Cells.PasteSpecial xlPasteValues
 
        Case "A"
            Sh.Copy after:=Wrk2.Sheets(Wrk2.Sheets.Count)
            Wrk2.Sheets(1).Cells.Copy
            Wrk2.Sheets(1).Cells.PasteSpecial xlPasteValues
 
    End Select
 
Next
 
Wrk1.Sheets("Feuil1").Delete
Wrk2.Sheets("Feuil1").Delete
 
Wrk1.SaveAs Filename:=ThisWorkbook.Path & "\Save A B C.xls", FileFormat:=XlFileFormat.xlExcel7
Wrk2.SaveAs Filename:=ThisWorkbook.Path & "\Save A B.xls", FileFormat:=XlFileFormat.xlExcel7
 
 
Wrk1.Close False
Wrk2.Close False
 
Set Wrk1 = Nothing
Set Wrk2 = Nothing
 
Application.DisplayAlerts = True
 
End Sub

[blanka347]

Merci comme d'habitude ça marche parfaitement merci !

Bonne soirée à toi !