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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
Sub CentreHospitalier()
Dim Classeur As Workbook
Dim Fe As Worksheet
Dim FeRecup As Worksheet
Dim TblNomFeuille() As String
Dim Plage As Range
Dim Cel As Range
Dim Dico As Object
Dim Cle As Variant
Dim NomFeuille As String
Dim Existe As Boolean
Dim I As Integer
'classeur de récup, adaper le nom
Set Classeur = Workbooks("Classeur2.xls")
'récupère les nom des feuilles pour un contrôle ultérieur
For Each Fe In Classeur.Worksheets
I = I + 1
ReDim Preserve TblNomFeuille(1 To I)
TblNomFeuille(I) = Fe.Name
Next Fe
'la feuille où se trouve la base de données, à adpter
Set Fe = ThisWorkbook.Worksheets("Feuil1")
'défini la plage seulement en colonne "A" sur les codes qui sont sensés être uniques
With Fe
Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'supprime les doublons de codes pour faire le filtrage par la suite
Set Dico = CreateObject("Scripting.Dictionary")
For Each Cel In Plage
If Cel.Row <> 1 Then '<-- évite la ligne d'entêtes
If Dico.exists(Cel.Value) = False Then
'construit le nom de la feuille à partir du mot "de" pour ne récupérer que la ville et rajoute "CH_" comme préfixe
NomFeuille = UCase("ch_" & Right(Cel.Offset(, 2).Value, Len(Cel.Offset(, 2).Value) - InStrRev(Cel.Offset(, 2).Value, "de") - 2))
'met ou remet à faux
Existe = False
'vérifie l'existance de cette feuille dans le classeur de récup
For I = 1 To UBound(TblNomFeuille)
If TblNomFeuille(I) = NomFeuille Then
Existe = True
Exit For
End If
Next I
'si la feuille n'existe pas (ou le nom n'est pas orthographié de la même manière) :
'- soit on la crée (clic sur le bouton "Oui")
'- soit on effectue la modif manuellement (clic sur le bouton "Non"), dans ce cas, fin de procédure
If Existe = False Then
If MsgBox("La feuille '" & NomFeuille & "' n'existe pas dans le classeur '" & Classeur.Name & "' ou son nom n'est pas orthographié de la même manière !" & _
vbCrLf & "Voulez-vous :" & vbCrLf & _
"1- faire la correction manuellement pour avoir la correspondance ? Cliquez sur 'Non'" & _
vbCrLf & "2- qu'un feuille soit créée ? Cliquez sur 'Oui'", _
vbExclamation + vbYesNo, _
"Vérification des noms de feuilles.") = vbYes Then
'si clic sur "Oui", ajoute une feuille à la fin de la collection et la renomme
Set FeRecup = Classeur.Worksheets.Add(, Classeur.Worksheets(Classeur.Worksheets.Count))
FeRecup.Name = NomFeuille
ReDim Preserve TblNomFeuille(1 To UBound(TblNomFeuille) + 1)
TblNomFeuille(I) = NomFeuille
Else
Exit Sub
End If
End If
'ajoute le code dans la clé et le nom de la feuille dans l'élément
Dico.Add Cel.Value, NomFeuille
End If
End If
Next Cel
'parcour le dico pour filtrer la base de données sur la colonne "A"
For Each Cle In Dico.Keys
'défini la feuille qui va recevoir les valeurs
Set FeRecup = Classeur.Worksheets(Dico(Cle))
'filtre
Plage.AutoFilter 1, Cle
'récupère les valeurs avec la ligne d'entête
With FeRecup
Fe.AutoFilter.Range.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
'supprime le filtre
Plage.AutoFilter
Next Cle
End Sub |
MACRO tableau multi donnees à copier par feuil
Répondre avec citation
Partager