Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim dur#, nomfich$, chemin$, nglobal%, d As Object, i&, nf$, df As Object
Dim a, classement As Boolean, w As Worksheet, j&, x As Variant, y As Variant
dur = Timer
nomfich = "ADH.xlsm" 'nom du classeur de destination à adapter
chemin = ThisWorkbook.Path & "\" 'chemin à adapter
nglobal = 4 'nombre de feuilles non adhérent du fichier de destination
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False 'désactive les évènements, au cas où...
On Error Resume Next
Workbooks.Open chemin & nomfich
With ActiveWorkbook
If .Name = Me.Name Or .ReadOnly Then
Cancel = True
If .ReadOnly Then .Close False
Application.ScreenUpdating = True
MsgBox "Enregistrement impossible, voyez avec l'Administrateur..."
Else
Me.Sheets(1).[A:Q].Copy .Sheets(1).[A1]
Me.Sheets(1).[A1].Copy .Sheets(1).[A1] 'vide le presse-papiers
'---liste des valeurs en colonne 1 sans doublon---
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To .Sheets(1).UsedRange.Rows.Count
nf = .Sheets(1).Cells(i, 1)
If nf <> "" Then d(nf) = i 'repérage de la ligne
Next
'---ligne 2 des feuilles ou suppression---
Set df = CreateObject("Scripting.Dictionary")
For i = .Sheets.Count To nglobal + 1 Step -1
nf = .Sheets(i).Name
If d.exists(nf) Then
.Sheets(1).Cells(d(nf), 1).Resize(, 17).Copy .Sheets(i).[A2]
df(nf) = ""
Else
.Sheets(i).Delete
End If
Next
'---création des feuilles manquantes---
If d.Count Then
a = d.keys
For i = 0 To UBound(a)
If Not df.exists(a(i)) Then
classement = True
Set w = .Sheets.Add(After:=.Sheets(.Sheets.Count))
w.Name = a(i)
.Sheets(1).Cells(1).Resize(, 17).Copy w.[A1]
.Sheets(1).Cells(d(a(i)), 1).Resize(, 17).Copy w.[A2]
w.Columns.AutoFit 'ajustement largeur
End If
Next
End If
'---classement des onglets---
If classement Then
For i = nglobal + 1 To .Sheets.Count 'on ne touche pas aux nglobal 1ers onglets
x = .Sheets(i).Name: If IsNumeric(x) Then x = CDbl(x)
For j = i + 1 To .Sheets.Count
y = .Sheets(j).Name: If IsNumeric(y) Then y = CDbl(y)
If y < x Then .Sheets(j).Move Before:=.Sheets(i)
Next j, i
End If
.Sheets(1).Activate
'---enregistrement et fermeture---
.Close True
End If
End With
Application.EnableEvents = True 'réactive les évènements
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - dur, "0.00 \s")
End Sub