Sub Dispatcher()
Dim t() As String
Application.ScreenUpdating = False 'on neutralise l'affichage,execution plus rapide
Application.Calculation = xlCalculationManual ' pas de calcul
Feuil4.Visible = True
With Sheets("BD") ' ou With Feuil1
num = .[E2] 'le point signifie le sheets("BD") du with
k = 2
For lig = 2 To .Range("E" & Rows.Count).End(3).Row + 1 'boucle de 2 au bas de col E +1
If .Cells(lig + 1, 5) <> num Then '.cells(ligne,colonne)
Sheets("modele").Copy After:=Sheets(Sheets.Count)
On Error Resume Next 'on gère si on va en error
ActiveSheet.Name = num 'on renomme l'onglet créé
If Err > 0 Then 'si error fait jusqu'a End if
Application.DisplayAlerts = False 'on évite le message d'alerte
Sheets(CStr(num)).Delete 'on supprime l'onglet si existant
'num est du numérique Cstr converti en text le numérique sinon bug
Application.DisplayAlerts = True ' on remets les messages d'alertes
ActiveSheet.Name = num ' le dernier onglet créé est renommé
Err.Clear 'effacement error donc plus d'error
End If
.Range("F" & k & ":I" & lig).Copy
Sheets(CStr(num)).[A2].PasteSpecial 'mets le numérique en texte et colle
num = .Cells(lig + 1, 5) 'on redonne la nouvelle valeur exemple: 10 ou 20....
If num = "" Then ' si num=rien on est en bas, on masque save et quitte
Feuil1.Visible = False 'masquer la BD ici j'utilise le Codename et non le Name
Feuil4.Visible = False 'masquer modele
Feuil2.Select
Application.Calculation = xlCalculationAutomatic 'remet en mode calcul
'sauvegarde
'chemin = ThisWorkbook.Path & "\" 'c'était pour moi
chemin = "S:\toto\tata\titi\Dessin\Isos\" 'pour toi ATTENTION bon chemin
fichier = "LISTE-ISOS-" & Format(Date, "yyyy-mm-dd") & ".xls"
'on va copier que les feuilles visibles. la copie va créer un nouveau fichier
'le fichier sera sans macro, sans modele ni BD
For Each c In Worksheets 'boucle sur toutes feuilles
If c.Visible = True Then
ReDim Preserve t(i): t(i) = c.Name: i = i + 1 ' création tablo "t" (nom des feuilles)
End If
Next
Sheets(t).Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=chemin & fichier, FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
Workbooks(fichier).Close 'on ferme le fichier sauvé
Application.ScreenUpdating = True 'on remets l'affichage
Exit Sub 'on est au bout, on quitte
End If
k = lig + 1 'k est la ligne du début de copie suivante
End If
Next
End With 'fin du with
'pas testé mais on peut mettre le calcul en manuel au début et le remettre en fin de macro pour accélérer
'l'enregistreur de macro te donneras le code si besoin
End Sub