Option Explicit
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
Dim DL As Long, Ligne As Long
Dim c
Chp = Array( _
Array("Nom", "Nom", "E6"), _
Array("Fonction", "Fonction", "E10"), _
Array("Néle", "Néle", "A1"), _
Array("Etat", "Etat", "N14"))
'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")
'*************************************************************************************************************
'C'est ici que tu peux remplacer la ligne de début pour la boucle
DL = .Rows.Count
Set c = Range(Cells(1, 1), Cells(DL, 1)).Find("Nom", LookIn:=xlValues, Lookat:=xlWhole)
If Not c Is Nothing Then
Ligne = c.Row
Else
Exit Sub
End If
'*************************************************************************************************************
For i = Ligne To .Rows.Count
ind = .Cells(i, 1)
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
Private Sub CommandButton1_Click()
toto
End Sub
