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

Consolidation Onglets condition

Autre exemple

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