Regrouper fichier

Question

Bonjour à tous,

J'ai besoin de votre aide concernant une macro.
J'ai une multitude de fichiers avec 5 onglets. J'aimerai regrouper les onglets des feuilles dans une même feuille.

Je me sers de cette macro pour regrouper les données de l'onglet 1 dans un feuille mais pour les onglets suivants, cela ne fonctionne pas.
Pourriez vous me donner des conseils, sachant que je débute vraiment en VBA.

Si je change la ligne Set Wl = ActiveWorkbook.Sheets(1) ' choix de la feuille
en indiquant (2) pour l'onglet 2, cela ne fonctionne pas. Cela me parais évident comme ca regroupe les données du répertoire et va donc chercher les données regroupées de l'onglet 1.

Sub regroupe()
Dim chemin As String    ' classeur regroupé
Dim rep As String       ' répertoire à traiter
Dim fic As String       ' classeur regroupé
Dim ligne As Long       ' ligne écriture
Dim nbc As Integer      ' nombre de classeurs
Dim nbf As Integer      ' nombre de feuilles
Dim nbl As Integer      ' nombre de lignes
Dim c As Integer        ' nombre de colonnes
Dim l As Long           ' ligne lecture
Dim Wf As Worksheet     ' feuille regroupement
Dim Wl As Worksheet     ' feuille regroupée
rep = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error GoTo fin
Set Wf = ThisWorkbook.ActiveSheet         ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0: nbf = 0                ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xls")    ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
    chemin = rep & fic       ' chemin fichiers
        Workbooks.Open chemin, 0  ' ouverture
        Set Wl = ActiveWorkbook.Sheets(1)  ' choix de la feuille
        nbl = Wl.UsedRange.Rows.Count
        c = Wl.UsedRange.Columns.Count
        If ligne > 2 Then l = 2 Else l = 1  ' une seule fois le titre
        Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
        ligne = ligne + nbl - l + 1
        nbf = nbf + 1
        ActiveWorkbook.Close SaveChanges:=False   ' Fermeture du classeur
        nbc = nbc + 1
End If
    fic = Dir
Wend
fin:
    MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    
 End Sub

J'espère avoir été assez clair pour que vous puissiez m'aider.

Merci d'avance pour votre réponse,

Frenchie83 · Answer

Bonjour
A essayer

Sub regroupe()
    Dim chemin As String    ' classeur regroupé
    Dim rep As String       ' répertoire à traiter
    Dim fic As String       ' classeur regroupé
    Dim ligne As Long       ' ligne écriture
    Dim nbc As Integer      ' nombre de classeurs
    Dim nbf As Integer      ' nombre de feuilles
    Dim nbl As Integer      ' nombre de lignes
    Dim c As Integer        ' nombre de colonnes
    Dim l As Long           ' ligne lecture
    Dim Wf As Worksheet     ' feuille regroupement
    Dim Wl As Worksheet     ' feuille regroupée
    rep = ThisWorkbook.Path & "\"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo fin
    Set Wf = ThisWorkbook.ActiveSheet         ' variable feuille groupe
    Wf.Cells.ClearContents
    nbc = 0: nbf = 0                ' initialisation variables
    ligne = 1
    fic = Dir(rep & "*.xls")    ' recherche fichiers
    While fic <> ""
        If fic <> ThisWorkbook.Name Then
            chemin = rep & fic       ' chemin fichiers
            Workbooks.Open chemin, 0  ' ouverture
            For i = 1 To 5
                Set Wl = ActiveWorkbook.Sheets(i)  ' choix de la feuille
                nbl = Wl.UsedRange.Rows.Count
                c = Wl.UsedRange.Columns.Count
                If ligne > 2 Then l = 2 Else l = 1  ' une seule fois le titre
                Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
                ligne = ligne + nbl - l + 1
                nbf = nbf + 1
            Next i
        End If
        fic = Dir
        ActiveWorkbook.Close SaveChanges:=False   ' Fermeture du classeur
        nbc = nbc + 1
    Wend
fin:
    MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
 End Sub

Cdlt

Frenchie83 · Answer

Bonsoir
Je n'ai pas très bien compris votre besoin;
 je voudrais que les informations quand
i = 2 aillent sur l'onglet "codes concernés"
i = 3 aillent sur l'onglet "processus" 
 et quand i=3,4,ou 5?.
 Pour ce que vous demandez, remplacez 
                Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
par
               
 If i = 2 Then
    Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Sheets("Codes concernés").Cells(ligne, 1)
ElseIf i = 3 Then
    Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Sheets("Processus").Cells(ligne, 1)
 End If

Cdlt

Frenchie83 · Answer

Ca ne marche pas parce qu'il faut lui dire de changer de fenêtres à chaque fois qu'on passe d'un fichier à l'autre.
Voici avec quelques modifs. Il y faudra sûrement l'adapter. A tester

Public FeuilleDestination As String
Public Ligne As Long
Public Nbf As Integer ' nombre de feuilles
Public nbl As Integer 'nombre de lignes
Public chemin As String ' classeur regroupé
Public rep As String ' répertoire à traiter
Public fic As String ' classeur regroupé
Public c As Integer ' nombre de colonnes
Public l As Long ' ligne lecture
Public Wf As Worksheet ' feuille regroupement
Public Wl As Worksheet ' feuille regroupée
Public i As Integer

Sub regroupe()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo fin
    rep = ThisWorkbook.Path & "\"
    Set Wf = ThisWorkbook.ActiveSheet ' variable feuille groupe
    Wf.Cells.ClearContents
    Ligne = 1
    fic = Dir(rep & "*.xls") ' recherche fichiers
    TableauDest = Array("Codes articles concernés", "Codes articles concernés", "Nomenclatures AC", "Processus de fabrication", "Parc TF")
    While fic <> ""
        For i = 1 To 8
            If fic = ThisWorkbook.Name Then Exit Sub
            chemin = rep & fic ' chemin fichiers
            Workbooks.Open chemin, 0 ' ouverture
            FeuilleDestination = TableauDest(i) ' "Codes articles concernés"
            RecopieFeuilleDestination
            Windows(fic).Activate
            ActiveWorkbook.Close SaveChanges:=False ' Fermeture du classeur
            fic = Dir
            nbc = nbc + 1
        Next
    Wend
fin:
    MsgBox nbc & " classeurs regroupés avec " & Nbf & " feuilles et " & Ligne & " lignes"
End Sub

Sub RecopieFeuilleDestination()
    Set Wl = ActiveWorkbook.Sheets(i) ' choix de la feuille
    nbl = Wl.UsedRange.Rows.Count
    c = Wl.UsedRange.Columns.Count
    If Ligne > 2 Then l = 2 Else l = 1 ' une seule fois le titre
    Wl.Cells(l, 1).Resize(nbl, c).Copy
    Windows("ClasseurRegroupé.xlsm").Activate
    Sheets(FeuilleDestination).Select
    Cells(Ligne, 1).Select
    ActiveSheet.Paste
    Ligne = Ligne + nbl - l + 1
    Nbf = Nbf + 1
End Sub
Cdlt

Regrouper fichier

3 réponses

Discussions similaires

Newsletters