Gestion des onglets et des classeurs

Accueil

 

Créer un onglet,renommer,copier,supprimer
Ouvrir fermer un classeur
Exemples
Création de plusieurs onglets
Création d'onglets à partir d'un modèle
Création d'onglets rapide
Création de plusieurs classeurs
Consolidation d'onglets d'un classeur
Consolidation de fiches dans une BD
Consolidation classeurs d'un sous-répertoire
Consolidation de sous-répertoires
Récupère onglets des classeurs d'un répertoire
Découpe un classeur en plusieurs classeurs
Sauvegarde
Sauvegarde avec date du jour
Sauvegarde indicée
SaveCopyAS

Sheets.Add
Sheets.Name
Sheets.Count
Sheets(onglet).delete
Sheets(onglet).copy
Sheets.Move
Workbooks(fichier).Open
Workbooks(fichier).Close
GetObject


Noms des feuilles d'un classeur

 

Créer un onglet- Renommer -Copier - Déplacer - Supprimer

Sheets.Add Before/After :=Sheets(onglet)

Sheets.Add ajoute un onglet au classeur actif.

Sheets.Add

Sheets(onglet).Name=nom

ActiveSheet.Name renomme l'onglet actif

Sheets(1).Name = "yyyy"
ActiveSheet.Name="yyyy"

Sheets(onglet).Delete

Sheets("xxx").Delete supprime la feuille xxx

Application.DisplayAlerts = False ' supprime les messages d'avertissement
Sheets(1).Delete
Sheets("xxx").Delete

Sheets.Move Before/After :=Sheets(onglet)

Sheets("xxx").Move Before/After :=Sheets(onglet) déplace l'onglet xxx

Sheets("Feuil1").Move Before:=Sheets(4)

Sheets.Count

Sheets.count donne le nombre d'onglets du classeur actif.

n = Sheets.Count

Sheets.Copy

Sheets("xxx").Copy Before/After :=Sheets(onglet) copy l'onglet xxx

Sheets("Feuil2").Copy Before:=Sheets(3)
Sheets("Feuil1").Copy            ' Copie l'onglet dans dans un nouveau classeur

Sélectionner tous les onglets

Sheets(1).Select
For s = 2 To Sheets.Count
Sheets(s).Select False
Next s

Ouvrir un classeur - fermer un classeur

Workbooks(fichier).Open

Workbooks.Open(fichier, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad, OpenConflictDocument

Ouvre le fichier spécifié.

Workbooks.Open "base.xls"

 Workbooks(fichier).Close savechanges:=True/False

Ferme le fichier spécifié.
L'option savechanges:=False évite le message d'avertissement 'voulez vous sauvegarder les modifications?'

 Workbooks(nf).Close savechanges:=False

Nombre de feuilles d'un classeur et noms des feuilles avec Macro XL4

=Lire.Classeur(4)

Pour obtenir le nombre de feuilles d'un classeur

-Créer un nom de champ NBFeuilles
=LIRE.CLASSEUR(4)&INDIRECT("iv65000")
Dans une cellule du tableur
=NbFeuilles

=Lire.Classeur(1)

Pour obtenir les noms des feuilles d'un classeur:

-Créer un nom de champ NomsFeuilles
=STXT(LIRE.CLASSEUR(1);TROUVE("]";LIRE.CLASSEUR(1))+1;99)&INDIRECT("iv65000")
-Sélectionner des cellules horizontales
=NomsFeuilles
-Valider avec Maj+Ctrl+entrée

NomsFeuilles

Exemples

Création de plusieurs onglets à partir d'une BD

Cree Onglets Service.xls
Cree Onglets mois.xls
Cree Onglets Service Modele.xls
Crée Onglets TravéeModèle
Cree Onglets Objets

On veut créer un onglet pour chaque service.

Sub Extrait()
  Set f = Sheets("BD")
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  '--- Liste des services
  f.[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=f.[G1], Unique:=True
  For Each c In f.Range("G2:G" & f.[G65000].End(xlUp).Row) ' pour chaque service
    f.[G2] = c.Value
    On Error Resume Next
    Sheets(c.Value).Delete
    On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count) ' création
    ActiveSheet.Name = c.Value
    '-- extraction
    f.[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[G1:G2], CopyToRange:=[A1]
  Next c
End Sub

Création d’onglets à partir d’un modèle

CréationFichesModèle.xls

Sub CreeOnglets()
  Application.ScreenUpdating = False
  supOnglets
  Set bd = Sheets("bd")
  bd.[A1].CurrentRegion.Sort Key1:=bd.Range("A2"), Order1:=xlAscending, Header:=xlGuess
  LigBD = 2
  Do While LigBD <= bd.[A65000].End(xlUp).Row
    nom = bd.Cells(LigBD, 1) ' Premier nom
    Sheets("modèle").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "F_" & nom
    Set fiche = Sheets("F_" & nom)
    fiche.Range("B3").Value = nom
    fiche.Range("b4").Value = bd.Cells(LigBD, "B")
    fiche.Range("b6").Value = bd.Cells(LigBD, "C")
    fiche.Range("b7").Value = bd.Cells(LigBD, "D")
    fiche.Range("b8").Value = bd.Cells(LigBD, "E")
    fiche.Range("b10").Value = bd.Cells(LigBD, "F")
    bd.Cells(LigBD, "G").Copy fiche.Range("b11")
    LigBD = LigBD + 1
  Loop
End Sub

Sub supOnglets()
  Application.DisplayAlerts = False
  For s = Sheets.Count To 1 Step -1
    If Left(Sheets(s).Name, 2) = "F_" Then Sheets(s).Delete
  Next s
End Sub

Création Onglets rapide (0,75 sec pour 32.000 lignes)

-Sachant que la BD est triée par code
.On mémorise dans la variable premier la position du premier item du bloc
.Dans une boucle, on recherche la position du dernier item du bloc
.On copie ce bloc dans un nouvel onglet
f.Cells(1+ Premier, 1).Resize(i - Premier - 1, Ncol).Copy [A2]

Création Onglets rapide
Création Onglets rapide avec 2 critères
Création Onglets Compare

Sub Extrait()
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Sheets("BD").Copy Before:=Sheets(1)
  Set f = Sheets(1)
  Ncol = 3           ' Adapter ou Ncol=f.[A1].CurrentRegion.Columns.Count
  colCritère = 2  ' adapter

  Derlig = f.[a65000].End(xlUp).Row
  Set Rng = f.Cells(2, 1).Resize(Derlig, Ncol)
  Rng.Sort key1:=f.Cells(2, colCritère)
  TblCrit = f.Cells(2, colCritère).Resize(Derlig - 1)
  i = 1: Premier = 1
  Do While i <= UBound(TblCrit)
    code = TblCrit(i, 1)
    Do While TblCrit(i, 1) = code
        i = i + 1: If i > UBound(TblCrit) Then Exit Do
    Loop
    On Error Resume Next: Sheets(code).Delete: On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = code
    f.Cells(1 + Premier, 1).Resize(i - Premier, Ncol).Copy [A2]
    f.Cells(1, 1).Resize(, Ncol).Copy [A1]
    Premier = i
  Loop
  Sheets(1).Delete
End Sub

Pour consolider les fiches dans une BD

Sub consolideOngletsBD()
  ligBD = 2
  Set bd = Sheets("bd")
  For f = 1 To Sheets.Count
    If Left(Sheets(f).Name, 2) = "F_" Then
      bd.Cells(ligBD, "A") = Sheets(f).[B3]
      bd.Cells(ligBD, "B") = Sheets(f).[B4]
      bd.Cells(ligBD, "C") = Sheets(f).[B6]
      bd.Cells(ligBD, "D") = Sheets(f).[B7]
      bd.Cells(ligBD, "E") = Sheets(f).[B8]
      bd.Cells(ligBD, "F") = Sheets(f).[B10]
      Sheets(f).[B11].Copy bd.Cells(ligBD, "G")
      ligBD = ligBD + 1
    End If
  Next f
End Sub

Autre exemple

CréationOngletsModèle.xls

Crée des onglets individuels pour chaque personne

-On dispose d'une BD avec les dates de congés.
-On veut créer des plannings individuels à partir d'un onglet Modèle.

 
Sub CreeOnglets()
  Application.ScreenUpdating = False
  supOnglets
  Set bd = Sheets("bd")
  bd.[A1].CurrentRegion.Sort Key1:=bd.Range("A2"), Order1:=xlAscending, Header:=xlGuess
  ligBD = 2
  Do While ligBD <= bd.[A65000].End(xlUp).Row
    nom = bd.Cells(ligBD, 1) ' Premier nom
    Sheets("modèle").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "F_" & nom
    Set plan = Sheets("F_" & nom)
    plan.Range("D5").Value = nom
    ligPlan = 9
    Do While bd.Cells(ligBD, 1) = nom 'parcours nom traité
      TypeConges = bd.Cells(ligBD, 4)
      jours = bd.Cells(ligBD, 5)
      plan.Cells(ligPlan, 3) = bd.Cells(ligBD, 2)
      plan.Cells(ligPlan, 4) = bd.Cells(ligBD, 3)
      p = Application.Match(TypeConges, [CodesConges], 0)
      If Not IsError(p) Then plan.Cells(ligPlan, p + 4) = jours
      ligBD = ligBD + 1
      ligPlan = ligPlan + 1
    Loop
  Loop
End Sub

Sub supOnglets()
  Application.DisplayAlerts = False
  For s = Sheets.Count To 1 Step -1
     If Left(Sheets(s).Name, 2) = "F_" Then Sheets(s).Delete
  Next s
End Sub

Sub exportOnglets()
  CheminAppli = ThisWorkbook.Path
  Application.DisplayAlerts = False
  For i = 1 To Sheets.Count
    If Left(Sheets(i).Name, 2) = "F_" Then
       Sheets(i).Select
       nonglet = ActiveSheet.Name
       ActiveSheet.Copy
       ActiveWorkbook.SaveAs Filename:=CheminAppli & "\" & nonglet
       ActiveWindow.Close
     End If
   Next i
End Sub

Création d'un classeur pour chaque pays

Sur cet exemple, on crée un classeur pour chaque pays:
-Le filtre élaboré extrait la liste des pays
-Une boucle extrait les lignes pour chaque pays

- CréeClasseursPays -

Sub CreeClasseurs()
  Application.DisplayAlerts = False
  [A1:D10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[g1], Unique:=True
  For Each c In Range("G2", Range("G65000").End(xlUp))
    Range("G2") = c
    Sheets.Add
    Sheets("BD2").[A1:D10000].AdvancedFilter Action:=xlFilterCopy, _
       CriteriaRange:=Sheets("BD2").[G1:G2], CopyToRange:=[A1], Unique:=False
    ActiveSheet.Copy
    ActiveSheet.Name = c
    ActiveWorkbook.SaveAs Filename:=c
    ActiveWorkbook.Close
    ActiveSheet.Delete
    Sheets("BD2").Select
  Next c
End Sub

L'opérateur choisit le critère d'extraction dans une liste déroulante en P1

Sub CreeClasseurs()
  Application.DisplayAlerts = False
  f = ActiveSheet.Name
  [A1].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[p1], Unique:=True
  For Each c In Range("P2", Range("P65000").End(xlUp))
    Range("P2") = c
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(f).[A1].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
       CriteriaRange:=Sheets(f).[P1:P2], CopyToRange:=[A1], Unique:=False
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=c
    ActiveWorkbook.Close
    ActiveSheet.Delete
    Sheets(f).Select
  Next c
End Sub

Consolidation d'onglets

On veut consolider des onglets (ConsolideOnglets.xls)

Version1

Sub consolide_onglets()
  Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
  For s = 2 To Sheets.Count
     Range(Sheets(s).[A2], Sheets(s).[A65000].End(xlUp).End(xlToRight)).Copy _
       [A65000].End(xlUp).Offset(1, 0)
  Next s
  On Error Resume Next
  [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Version2

S'il y a des formules dans les onglets.

Sub consolide_onglets2()
    Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
    For s = 2 To Sheets.Count
      nlig = Sheets(s).[A65000].End(xlUp).Row - 1
      ncol = Sheets(s).[A1].CurrentRegion.Columns.Count
     [A65000].End(xlUp).Offset(1, 0).Resize(nlig, ncol).Value = _
     Sheets(s).[A2].Resize(nlig, ncol).Value
   Next s
   On Error Resume Next
   [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Version3 (collage spécial)

S'il y a des formules dans les onglets.

Sub consolide_ongletsCollageSpecial()
   Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
   For s = 2 To Sheets.Count
     nlig = Sheets(s).[A65000].End(xlUp).Row - 1
     ncol = Sheets(s).[A1].CurrentRegion.Columns.Count
     Sheets(s).[A2].Resize(nlig, ncol).Copy
     [A65000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
  Next s
  On Error Resume Next
  [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Version4 (ajoute les noms des onglets dans une colonne)

Sub consolide_ongletsNomOnglet()
   Sheets("base").[A1].CurrentRegion.Offset(1, 0).Clear
   For s = 2 To Sheets.Count
      nlig = Sheets(s).[A65000].End(xlUp).Row - 1
      ncol = Sheets(s).[A1].CurrentRegion.Columns.Count
      [A65000].End(xlUp).Offset(1, ncol).Resize(nlig, 1).Value = Sheets(s).Name
      [A65000].End(xlUp).Offset(1, 0).Resize(nlig, ncol).Value = _
      Sheets(s).[A2].Resize(nlig, ncol).Value
   Next s
   On Error Resume Next
   [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Consolide un ensemble d'onglets (Onglet1,Onglet2,Onglet5,..)

Sub consolide_onglets()
  Sheets("synthese").[A1].CurrentRegion.Offset(1, 0).Clear
  For Each s In Array("Onglet1", "Onglet2", "Onglet5")
      Sheets(s).[A1].CurrentRegion.Offset(1, 0).Copy _
          Sheets("synthese").[A65000].End(xlUp).Offset(1, 0)
   Next s
End Sub

Consolidation avec condition

Dans les onglets Machine1, Machine2,...on ne prend que les lignes qui contiennent OUI en colonne E.

Sub recap()
  ligne = 2
  For s = 2 To Sheets.Count
     For lig = 2 To Sheets(s).[A65000].End(xlUp).Row
       If Sheets(s).Cells(lig, 5) = "OUI" Then
         Sheets(s).Rows(lig).Copy Sheets("commande").Cells(ligne, 1)
         Cells(ligne, 6) = Sheets(s).Name
         ligne = ligne + 1
       End If
     Next lig
  Next
End Sub

Sub recap2()
   ligne = 2
   For Each s In Array("machine1", "machine2")
     For lig = 2 To Sheets(s).[A65000].End(xlUp).Row
       If Sheets(s).Cells(lig, 5) = "OUI" Then
         Sheets(s).Rows(lig).Copy Sheets("commande").Cells(ligne, 1)
         Cells(ligne, 6) = s
         ligne = ligne + 1
       End If
   Next lig
Next
End Sub

Autre exemple

Dans les onglets N°1,N°2,.. on ne prend que les lignes qui contiennent un libellé en colonne B:

Sub Recap()
   ligne = 3
   For Each s In Array("N°1", "N°2")
      For lig = 5 To Sheets(s).[B65000].End(xlUp).Row
        If Sheets(s).Cells(lig, 2) <> "" Then
          Sheets(s).Cells(lig, 2).Resize(, 10).Copy
          Sheets("synthese").Cells(ligne, 2).PasteSpecial Paste:=xlValues
          Sheets("synthese").Cells(ligne, 1) = s
          ligne = ligne + 1
        End If
     Next lig
   Next s
End Sub

Sub Recap2()
   ligne = 3
   For Each f In ActiveWorkbook.Sheets
     s = f.Name
     If s Like "N°*" Then
       For lig = 5 To Sheets(s).[B65000].End(xlUp).Row
         If Sheets(s).Cells(lig, 2) <> "" Then
           Sheets(s).Cells(lig, 2).Resize(, 10).Copy
           Sheets("synthese").Cells(ligne, 2).PasteSpecial Paste:=xlValues
           Sheets("synthese").Cells(ligne, 1) = s
           ligne = ligne + 1
         End If
       Next lig
     End If
   Next
End Sub

Autre exemple

Copie les lignes à NON des onglets Janvier,Février,...

OngletsCopieLignes

Private Sub Worksheet_Activate()
  [A2:f1000].ClearContents
  For s = 2 To Sheets.Count
     For lig = 2 To Sheets(s).[A65000].End(xlUp).Row
       If UCase(Sheets(s).Cells(lig, "F")) = "NON" Then
          Sheets(s).Cells(lig, 1).Resize(, 5).Copy [A65000].End(xlUp).Offset(1, 1)
          [A65000].End(xlUp).Offset(1) = Sheets(s).Name
       End If
     Next lig
   Next s
End Sub

Consolidation d'onglets avec des structures différentes

ConsoOnglets

Sub conso()
  Set synt = Sheets("synthèse")
  synt.[A2:I10000].ClearContents
  For s = 2 To Sheets.Count
    ligne = synt.[A1].CurrentRegion.Rows.Count + 1
    ncol = Sheets(s).[A1].CurrentRegion.Columns.Count + 1
    For t = 1 To ncol
      titre = Sheets(s).Cells(1, t)
      Set result = synt.Rows(1).Find(what:=titre)
      If Not result Is Nothing Then
        ligne2 = Sheets(s).[A1].CurrentRegion.Rows.Count + 1
        Sheets(s).Range(Sheets(s).Cells(2, t), Sheets(s).Cells(ligne2, t)).Copy synt.Cells(ligne, result.Column)
      End If
    Next t
  Next s
End Sub

Consolidation de fiches dans une BD

On veut consolider des fiches fiche1.xls,fiches2.xls,... dans une BD - ConsolidationFichesBD -

Sub Transfert()
  ChDir ThisWorkbook.Path ' Répertoire application
  ClassActuel = ThisWorkbook.Name
  Range("A2:J1000").ClearContents
  Range("b2").Select
  nf = Dir("fiche*.xls") ' Première fiche
  Do While nf <> ""
     Workbooks.Open Filename:=nf
     Range("C3:C11").Copy
     Windows(ClassActuel).Activate
     Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=True
     Workbooks(nf).Close savechanges:=False
     ActiveCell.Offset(0, -1) = nf
     ActiveCell.Offset(1, 0).Select
     nf = Dir() ' Fiche suivante
  Loop
End Sub

Consolidation de classeurs d'un sous-répertoire

On consolide des onglets provenant des classeurs d'un sous-répertoire nommé BD.

Sub syntèseClasseursBD2()
  sousRépertoire = "BD"
  [A2].CurrentRegion.Offset(1, 0).Clear
  Set maitre = ActiveWorkbook
  Repertoire = ThisWorkbook.Path
  nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
  Do While nf <> ""
    Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf
    n = [A1].CurrentRegion.Rows.Count - 1
    [A1].CurrentRegion.Offset(1, 0).Copy _
    maitre.Sheets(1).[A65000].End(xlUp).Offset(1, 0)
    ActiveWorkbook.Close False
    '-- nom onglet
    [A1].End(xlDown).End(xlToRight).Offset(-n + 1, 1).Resize(n, 1) = Left(nf, Len(nf) - 4)
    nf = Dir ' fichier suivant
  Loop
End Sub

Consolidation de fichiers de plusieurs sous-répertoires d'un répertoire

Dans SyntheseClasseurs.xls, on consolide des classeurs Hyper1.xls,Hyper2.xls,... situés dans des sous-répertoires d'un répertoire. Ces classeurs contiennent jusqu'à 6 lignes (A4:F10).

SynthèseClasseurs

Un niveau de sous-répertoires

Sub ConsolideSousRepRepActuel()
  Application.ScreenUpdating = False
  [A2:G1000].ClearContents
  répertoire = ThisWorkbook.Path
  ClasseurMaitre = ThisWorkbook.Name
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier = fs.getfolder(répertoire)
  For Each d In dossier.SubFolders
    sousRépertoire = d.Name
    nf = Dir(répertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
    Do While nf <> ""
      Workbooks.Open Filename:=répertoire & "\" & sousRépertoire & "\" & nf
      nlig = [A65000].End(xlUp).Row - 3
      [A4].Resize(nlig, 6).Copy Workbooks(ClasseurMaitre).Sheets(1).[B65000].End(xlUp).Offset(1, 0)
      Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 0).Resize(nlig).Value = [B1]
      ActiveWorkbook.Close False
      nf = Dir ' fichier suivant
    Loop
  Next
End Sub

Toute l'arborescence des sous répertoires

Dim ClasseurMaitre, répertoire
Sub ConsolideArborescence()
  Application.ScreenUpdating = False
  [A2:G1000].ClearContents  
  ClasseurMaitre = ThisWorkbook.Name
  répertoire = ThisWorkbook.Path
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set DossierRacine = fs.getfolder(répertoire)
  Lit_dossier DossierRacine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)
   For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
   Next
   For Each f In dossier.Files
     nf = f.Name
     If répertoire <> dossier Then 
       Workbooks.Open Filename:=dossier & "\" & nf
       nlig = [A65000].End(xlUp).Row - 3
       [A4].Resize(nlig, 6).Copy Workbooks(ClasseurMaitre).Sheets(1).[B65000].End(xlUp).Offset(1, 0)
       Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 0).Resize(nlig).Value = [B1]
       ActiveWorkbook.Close False
     End If
   Next
End Sub

Un seul sous-répertoire nommé BD

Sub syntèseClasseursBD()
   Application.ScreenUpdating = False
   sousRépertoire = "BD"
   [A2:G1000].ClearContents
   ClasseurMaitre = ThisWorkbook.Name
   répertoire = ThisWorkbook.Path
   nf = Dir(répertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
   Do While nf <> ""
      Workbooks.Open Filename:=répertoire & "\" & sousRépertoire & "\" & nf
      nlig = [A65000].End(xlUp).Row - 3
      [A4].Resize(nlig, 6).Copy Workbooks(ClasseurMaitre).Sheets(1).[B65000].End(xlUp).Offset(1, 0)
      Workbooks(ClasseurMaitre).Sheets(1).[A65000].End(xlUp).Offset(1, 0).Resize(nlig).Value = [B1]
      ActiveWorkbook.Close False
      nf = Dir ' fichier suivant
   Loop
End Sub

Récupère dans un classeur tous les onglets des classeurs d'un répertoire

ConsolideClasseursRepertoire

Sub consolide()
  ' Ce classeur et les classeurs à consolider sont dans le même répertoire
  répertoire = ThisWorkbook.Path
  Set classeurMaitre = ActiveWorkbook
  sup
  compteur = 1
  nf = Dir(répertoire & "\*.xls") ' premier fichier
  Do While nf <> ""
    If nf <> classeurMaitre.Name Then
      Workbooks.Open Filename:=nf
      For k = 1 To Sheets.Count
        Sheets(k).Copy After:=classeurMaitre.Sheets(classeurMaitre.Sheets.Count)
        classeurMaitre.Sheets(classeurMaitre.Sheets.Count).Name = "Mapage" & compteur
        compteur = compteur + 1
      Next k
      Workbooks(nf).Close False
    End If
    nf = Dir
    Loop
End Sub

Sub sup()
  Application.DisplayAlerts = False
  If Sheets.Count > 1 Then
    Sheets("Accueil").Move before:=Sheets(1)
    Sheets(2).Select
    For i = 2 To Sheets.Count
      ActiveSheet.Delete
    Next i
  End If
End Sub

Découpe un classeur en plusieurs classeurs

Sub DecoupeClasseurPlusieurs()
  Application.DisplayAlerts = False
  ChDir ActiveWorkbook.Path
  For Each s In ActiveWorkbook.Sheets
    s.Copy
    ActiveWorkbook.SaveAs Filename:=s.Name
    ActiveWorkbook.Close
  Next s
End Sub

Sauvegarde

Sauvegarde le classeur avec la date du jour

Le fichier est sauvegardé sous la forme Fichier du 28-08-2007.

Sub sauvegarde()
  'Répertoire = "c:\x\"
  répertoire = ActiveWorkbook.Path
  ActiveWorkbook.SaveAs Filename:=répertoire & "\FichierDu" & Format(Date, "dd-mm-yyyy")
End Sub

Sauvegarde indicée

Le fichier xxxx est sauvegardé sous les noms de xxxx1.xls,xxxx2.xls,....

Sub sauvegardeIndice()
  'Répertoire = "c:\x\"
  répertoire = ActiveWorkbook.Path
  nomFichier = "xxxx"
  nf = Dir(répertoire & "\" & nomFichier & "*")
  n = 0
  Do While nf <> ""
    n = n + 1
    nf = Dir
  Loop
  ActiveWorkbook.SaveAs Filename:=répertoire & "\" & nomFichier & "_" & n + 1
End Sub

SaveCopyAs

Enregistre une copie du classeur dans un fichier sans modifier le nom du classeur actuel.

Sauvegarde dans un autre répertoire

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  If Not ThisWorkbook.Saved Then ThisWorkbook.Save
    Répertoire = "c:\cegos"
    If Dir(Répertoire, vbDirectory) = "" Then MkDir Répertoire
    On Error Resume Next
    ThisWorkbook.SaveCopyAs Répertoire & "\" & ThisWorkbook.Name
End Sub

Copie de sauvegarde sous un autre nom dans un sous-répertoire répertoire Sauv

Sub sauvegarde2()
  ThisWorkbook.Save
  SRépertoire = "Sauv"
  Répertoire = ThisWorkbook.Path & "\" & SRépertoire
  If Dir(Répertoire, vbDirectory) = "" Then MkDir Répertoire
  ThisWorkbook.SaveCopyAs Répertoire & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & _
      Format(Now, "dd-mm-yyyy") & ".xls"
End Sub

Sélection de plusieurs onglets

Sélectionne tous les onglets à partir du 3eme

Sub SelectionOngletsMultiples()
  Sheets(3).Select
  For i = 4 To Sheets.Count
      Sheets(i).Select False
  Next i
End Sub

GetObject()

GetObject(fichier) ouvre un fichier et le masque.

Dans l'exemple, on tri une BD en A1 du fichier fermé BD.XLS.

TriBD    BD

Sub TriBaseGetObject()
  répertoire = ThisWorkbook.Path
  fichier = "bd.xls"
  Application.ScreenUpdating = False
  GetObject (répertoire & "\" & fichier)
  Workbooks(fichier).Sheets(1).[A1].CurrentRegion.Sort _
     Key1:=Workbooks(fichier).Sheets(1).[A1], Order1:=xlAscending, Header:=xlGuess
  Windows(fichier).Visible = True
  Workbooks(fichier).Save
  Workbooks(fichier).Close
End Sub

Avec WorkBooks.Open()

Sub TriBase()
  répertoire = ThisWorkbook.Path
  fichier = "bd.xls"
  Application.ScreenUpdating = False
  Workbooks.Open (répertoire & "\" & fichier)
  Workbooks(fichier).Sheets(1).[A1].CurrentRegion.Sort _
     Key1:=Workbooks(fichier).Sheets(1).[A1], Order1:=xlAscending, Header:=xlGuess
  Windows(fichier).Visible = True
  Workbooks(fichier).Save
  Workbooks(fichier).Close
End Sub

 

 

 

 

 

 

 

 

 

 

 

 

 

 

Création d'onglets

Création Onglets
Création Onglets Modèle
Crée classeurs service
Crée Classeurs Pays
Crée classeurs respons
Crée classeurs respons2
Création Fiches Produits
Création onglets jour

Consolidation d'onglets

Consolide onglets
Consolidation fiches BD
Consolide classeurs répert
Modif fichiers répertoire
Ajout Fiche BD

Formules onglets

Formules onglets

Onglet indirect

Onglet indirect Avant

Fonctions perso onglets