Dispatcher données en plusieurs onglets avec copie de mise en page et plus

[Canklown]

Bonjour à tous,

Je suis nouveau sur le forum, et j'ai quelques base en Excel mais pas du tout en VBA.

J'ai déjà regarder d'autres sujets mais je n'ai pas trouver de macros VBA adapté à mon besoin.

J'ai une liste de tuyauteries générale que je souhaite découper en plusieurs onglets.

Vous trouverez ci-dessous le déroulement que de la macro que je souhaite (cela peut peut-être servir).

1 Dispatcher les données de Feuil1 dans différents onglet

• Copier les données à partir de la colonne F.

• Nom de l’onglet = valeur de colonne E.

• Copier la ligne d’entête de Feuil1.

• Copier la mise en page de Feuil1.

• Mettre en forme de tableau en affichant le total des lignes.

• Définir la zone d’impression par rapport au tableau.

• Placer les onglets crées après Page de garde dans l'ordre croissant.

2 Masquer l’onglet Feuil1.

3 Enregistrer sous S:\toto\tata\titi\Dessin\Isos\LISTE-ISOS-date du jour.xlsx (date au format yyyy-mm-dd).

Vous trouverez ci-dessous un fichier qui contient 3 onglets:

Onglet Feuil1: Onglet des données sources.
Onglet Page de garde: Page de garde du document.
Onglet 10: Exemple d'un onglet après le dispatching des données.

Je vous remercie par avance du temps que vous me consacrerez.

 

[youky(BJ)]

Re : Dispatcher données en plusieurs onglets avec copie de mise en page et plus

Salut bien,
Bienvenu au forum
Ben dit donc ! pour ton 1er message tu demandes déja du pointu...Bravo
J'ai réalisé une macro incluse dans ce fichier, elle fait ce que tu demandes sauf que j'ai oublié
de faire la sauvegarde de chaque fiche et masquer la Feuil1. Par contre j'ai un onglet "modele" que l'on peux masquer.
Regarde déja si le résultat conviens.
Pour eviter les plantages si la feuille existe j'efface l'ancienne, pour essai effaces les onglets à partir de 10-20.....au bout, car j'ai testé alors verifie.
Bruno

 

[Canklown]

Re : Dispatcher données en plusieurs onglets avec copie de mise en page et plus

Merci Bruno,

Ca fonctionne nickel.

La suppression des onglets déjà existant, ça me plait, je n'y avais pas pensé.

Je sais que l'on peut ajouter des commentaires dans la macro, ce serait impeccable que tu puisses m'indiquer a peu près à quoi correspondent les différentes étapes.

J'ai juste modifié:

Sheets("BD").Range("E" & k & ":I" & lig).Copy

Par:

Sheets("BD").Range("F" & k & ":I" & lig).Copy

Parce qu'il y avait un décalage dans les colonnes.
J'ai quand même réussi à trouver à quoi correspondait cette ligne.

Sinon pour ce qui est de la sauvegarde automatique c'est un petit plus.
Par contre j'aurais aimé masquer les onglets modele et BD en automatique.

J'ai essayé enregistrer la macro pour masquer les onglets concernés mais je n'arrive pas à l'inclure dans la tienne.

Et encore merci!!!
Tu me fais gagner un temps qui devient de plus en plus précieux.

 

[youky(BJ)]

Re : Dispatcher données en plusieurs onglets avec copie de mise en page et plus

Bonsoir,
content que ça marche!
bon voici pour masquer les onglets et les explications.
J'ai modifié des lignes après IF num=""
Demain je regarde pour les sauvegardes
Bruno

Sub Dispatcher()
Application.ScreenUpdating = False 'on neutralise l'affichage,execution plus rapide
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
' ci-dessous le Sheets("BD")   peut être supprimé (oubli de ma part)
 If Sheets("BD").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
  Sheets("BD").Range("E" & k & ":I" & lig).Copy
  Sheets(CStr(num)).[A2].PasteSpecial
  num = Sheets("BD").Cells(lig + 1, 5) 'on redonne la nouvelle valeur exemple: 10 ou 20....
  If num = "" Then ' si num=rien on  est en bas, on quitte
    Feuil1.Visible = False 'masquer la BD ici j'utilise le Codename et non le Name
    Feuil4.Visible = False 'masquer modele
    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

Edit : j'ai pas fait ta rectif dans la ligne de Copy

 

[youky(BJ)]

Re : Dispatcher données en plusieurs onglets avec copie de mise en page et plus

Voici une nouvelle version qui sauvegarde seulement les onglets visibles et le fichier sauvegardé n'aura plus de macro.
Attention de bien Indiquer le chemin car je doute du "toto\tata\tutu" ceci pour l'enregistrement
j'ai remis comme tu avais fait à .Range("F" & k & ":I" & lig).Copy F au lieu de E
Au cas ou tu aurais un plantage en cours de macro, après avoir arrêté, affiche la fenêtre Exécution
et copie ces 3 lignes dedans et ensuite tu mets le curseur à la fin de chaque ligne et tu tapes entrée
Application.ScreenUpdating =True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

je te dis cela car on ne sait jamais mais ne prend pas peur
Bruno

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