Deplacer/copier dans un nouveau classeur

**blanka347** · 12/10/2011, 19h30

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** · 12/10/2011, 20h54

Bonjour,

Ci dessous une solution. dis nous si ok

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
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** · 12/10/2011, 21h54

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 :

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
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** · 12/10/2011, 22h05

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 :

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
    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** · 12/10/2011, 22h24

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 :

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
 
 
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** · 13/10/2011, 15h07

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 :

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
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

Deplacer/copier dans un nouveau classeur

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager