Sub Toto()
Dim i&, j&, ind$, tmp$, Chp(), oSh(), oKeys(), oItms(), oDt As Scripting.Dictionary
Dim LObj As ListObject
'correspondance des champs des feuilles "base" et "Modele", DANS L'ORDRE DES CHAMPS DE "base".
Chp = Array( _
Array("NOM", "Nom : ", "B4"), _
Array("Prénom", "Prénom : ", "B5"), _
Array("Propriété", "Propriété : ", "B6"), _
Array("Instrument", "Instrument : ", "B7"), _
Array("Marque", "Marque :", "B8"), _
Array("Type", "Type :", "B9"), _
Array("N°", "N° :", "B10"), _
Array("Choix option", "Choix option :", "B11"), _
Array("Tarif à l'année", "Tarif à l'année : ", "J12"), _
Array("Réglé le", "Réglé le :", "B12"))
' Définition du tableau structuré
Set LObj = Sheets("Base").ListObjects("Tableau1")
' Vérifier si des lignes existes
If LObj.ListRows.Count = 1 Then Exit Sub 'Rien à traiter
' Vérifier l'ordre des champs
For i = 0 To UBound(Chp)
If Chp(i)(0) <> LObj.HeaderRowRange.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 = 1 To LObj.ListRows.Count ' De la première ligne de données à la dernière
With LObj.DataBodyRange
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)
End With
Next
'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("Modele").Copy Before:=Worksheets("Modele")
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
Call Masque
Next i
Sheets("Base").Activate
With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
Set oDt = Nothing: Erase Chp(), oSh(), oKeys(), oItms()
End Sub