Sub toto()
' *** 10 Ventôse CCXIX *** Roger fecit. ***
'
'Référence à la biliothèque Microsoft Scripting Runtime (scrrun.dll) requise.
'"dat" est une plage nommée de la feuille "Base" :
'=DECALER(Base!$A$1;;;MAX((DECALER(Base!$A$1;;;NEnr;1)<>"")*LIGNE(DECALER(Base!$1:$1;;;NEnr;)));MAX((DECALER(Base!$A$1;;;;NChp)<>"")*COLONNE(DECALER(Base!$A:$A;;;;NChp))))
'Adapter les paramètres nommé "NEnr" (nb. max d'enregistrements) et "NChp" (nb. max de champs) si besoin est.
'
Dim i&, j&, ind$, tmp$, Chp(), oSh(), oKeys(), oItms(), oDt As Scripting.Dictionary
Chp = Array( _
Array("NOM", "NOM : ", "C14"), _
Array("Prenom", "Prénom : ", "C16"), _
Array("Date naissance", "Date de naissance : ", "C18"), _
Array("Division", "Division : ", "C20"), _
Array("Français", "Français", "D26"), _
Array("Maths", "Mathématiques", "D28"), _
Array("HG", "Histoire-Géographie", "D30"), _
Array("SVT", "S V T", "D32"), _
Array("LV1", "LV 1", "D34"), _
Array("LV2", "LV 2", "D36") _
) 'correspondance des champs des feuilles "base" et "releve", DANS L'ORDRE DES CHAMPS DE "base".
With Range("dat")
If .Rows.Count = 1 Then Exit Sub 'Rien à traiter.
For i = 0 To UBound(Chp)
If Chp(i)(0) <> .Cells(1, 1 + i) Then MsgBox ("Base inadéquate"): Exit Sub 'Base inadéquate.
Next
'
'Ventilation de la base par onglet :
Set oDt = CreateObject("Scripting.Dictionary")
For i = 2 To .Rows.Count
ind = .Cells(i, 1) & "_" & .Cells(i, 2)
tmp = ""
Do While oDt.Exists(ind & tmp): tmp = " " & CStr(Val(tmp) + 1): Loop 'Gestion des homonymies.
oDt.Add ind & tmp, Array(ind & tmp, .Rows(i).Value)
Next
End With
'
'Répertoire des feuilles existantes :
ReDim oSh(1 To Sheets.Count)
For i = 1 To Sheets.Count: oSh(i) = Sheets(i).Name: Next
'
'création/mise à jour des onglets :
oKeys = oDt.Keys
With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
For i = 0 To oDt.Count - 1
For j = 1 To UBound(oSh)
If oKeys(i) = oSh(j) Then Exit For
Next j
If j > UBound(oSh) Then 'Nouvelle feuille
Worksheets("Releve").Copy Before:=Worksheets("Releve")
ActiveSheet.Name = oKeys(i)
Else 'Feuille existante
Worksheets(oKeys(i)).Activate
End If
oItms = oDt(oKeys(i))(1)
For j = 0 To UBound(Chp): ActiveSheet.Range(Chp(j)(2)) = oItms(1, j + 1): Next
Next i
Me.Activate
With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
Set oDt = Nothing: Erase Chp(), oSh(), oKeys(), oItms()
End Sub
