XL 2013 Modification d'un code VBA pour fusionner des classeurs

[sr94]

Bonjour

J'ai récupéré sur un site la macro suivante :

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

J'ai plusieurs classeurs placés dans le répertoire "BD" , il n'y a qu'une seule feuille par classeur, toujours de structure identique, et je souhaiterais les compiler sur une seule feuille d'un classeur.
Comment puis je rajouter juste le code pour que les feuilles qui ont des données filtrées ne soient plus filtrées ?

Par ailleurs j'ai une erreur 1004 (erreur définie par l'application ou par l'objet) sur la ligne

    [A1].End(xlDown).End(xlToRight).Offset(-n + 1, 1).Resize(n, 1) = Left(nf, Len(nf) - 4)

mais cette ligne n'a pas l'air indispensable

Avant j'utilisais le code suivant, mais il est trop lourd (une demi heure pour 30 classeurs et au total 7000 lignes), le code ci-dessus fait la même chose en quelques secondes mais sans retirer le filtre.

Option Explicit

Sub Compilation()
  Dim fileName As String
  Dim wb As Workbook
  
  ThisWorkbook.Worksheets(1).Range("A3:AF" & ThisWorkbook.Worksheets(1).Range("A3").CurrentRegion.Rows.Count).EntireRow.Delete
  
  fileName = Dir(ActiveWorkbook.Path & "\*.xls*")
  
  Application.ScreenUpdating = False
  
  Do While fileName <> ""
    If fileName <> ThisWorkbook.Name Then
      Set wb = Workbooks.Open(ActiveWorkbook.Path & "\" & fileName)
      
      
      With wb.Worksheets(1)
      If .FilterMode Then .ShowAllData
      End With
 
      wb.Worksheets(1).Range("A2:AF" & wb.Worksheets(1).Range("D2").CurrentRegion.Rows.Count).Copy
      ThisWorkbook.Worksheets(1).Activate
      Range("A" & Worksheets(1).Range("A2").CurrentRegion.Rows.Count + 1).Select
      ActiveSheet.Paste
      wb.Close False
    End If
        
    fileName = Dir
  Loop

  Set wb = Nothing
  
  Application.ScreenUpdating = True
  
End Sub

Merci beaucoup

 

[vgendron]

Re : Modification d'un code VBA pour fusionner des classeurs

Bonjour,
pour tes filtres, je pense qu'il suffit de s'inspirer du code que tu utilisais précédemment et reprendre cette ligne
if .FilterMode Then .ShowAllData

ce qui te donnerait quelque chose comme ca: ?? pas testé

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
   if nf.FilterMode Then nf.ShowAllData
    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

pour l'erreur...??