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
| Function CopySheets(SheetsList As Variant, Optional oWorkbook As Workbook) As Workbook
' Renvoie un objet classeur représentant le nouveau classeur contenant les copies
' Les feuilles à copier doivent provenir d'un même classeur
' Author : Philippe Tulliez (www.magicoffice.be)
' Version : 1.2
' Arguments
' SheetsList Array ou String contenant le nom des feuilles à copier
' si String : propriété Name des feuilles à copier (le séparateur doit être un ;)
' si Array : propriété CodeName des feuilles à copier
' [oWorkbook] Objet Workbook parent des feuilles à copier (d:=ActiveWorkbook)
'
' Déclaration et assignation des variables
Dim Sht As Worksheet ' Objet feuille utilisé dans la boucle
Dim Nwk As Workbook ' Objet représentant le nouveau classeur construit avec les feuilles copiées
Dim Shn As Integer ' Variable de la boucle
Dim CnC As Byte ' Compteur des copies
Dim Tbl As Variant '
If oWorkbook Is Nothing Then Set oWorkbook = ActiveWorkbook
If TypeName(SheetsList) = "String" Then
Tbl = Split(SheetsList, ";")
Else
Tbl = SheetsList
End If
For Shn = LBound(Tbl) To UBound(Tbl)
With oWorkbook
For CnC = 1 To .Worksheets.Count
If StrComp(.Worksheets(CnC).CodeName, Tbl(Shn), vbTextCompare) = 0 Then
Tbl(Shn) = .Worksheets(CnC).Name
End If
Next
End With
Next
'
With oWorkbook
CnC = 0
For Shn = LBound(Tbl) To UBound(Tbl)
Set Sht = .Worksheets(Tbl(Shn))
' Copie des feuilles répondant aux critères
If CnC Then
Sht.Copy After:=Nwk.Worksheets(Nwk.Worksheets.Count)
Else
Sht.Copy
Set Nwk = ActiveWorkbook
CnC = CnC + 1
End If
Next
End With
Set CopySheets = Nwk
Set Nwk = Nothing: Set Sht = Nothing
End Function |
