Regrouper fichier

pacout59 Messages postés 3 Statut Membre -  
Frenchie83 Messages postés 2254 Statut Membre -
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,
A voir également:

3 réponses

Réponse 1 / 3
Frenchie83 Messages postés 2254 Statut Membre 339
 
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
0
pacout59 Messages postés 3 Statut Membre
 
Bonjour Frenchie,

J'ai bien pris en compte ton message.
Cependant, j'ai un peu décortiqué la macro en faisant toutes les boucles.
Le problème que j'ai est que tous les onglets viennent se coller dans le premier onglet.
Comment puis je identifier le nom de l'onglet ou je veux que ce soit collé ?


J'imagine que le choix s'effectue à cette ligne mais je ne sais pas comment le mentionner.
Ex : je voudrais que les informations quand
i = 2 aillent sur l'onglet "codes concernés"
i = 3 aillent sur l'onglet "processus" 

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
   
    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
   
                
            i = 2
               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, 2)
               ligne = ligne + nbl - l + 1
               nbf = nbf + 1
                
           i = 3
               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
                
            'i = 4
            '    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
                
           ' i = 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
               
               
                ActiveWorkbook.Close SaveChanges:=False   ' Fermeture du classeur
                
        End If
        fic = Dir
        nbc = nbc + 1
    Wend
fin:
    MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
 End Sub



Merci d'avance.
0
pacout59 Messages postés 3 Statut Membre > pacout59 Messages postés 3 Statut Membre
 
Bonjour Frenchie,

Merci encore pour ta réponse.
Je ne m'étais donc pas trompé sur la ligne à modifier :)

J'ai donc bien modifié cette ligne comme tu me l'as précisé. En revanche, cela ne me copie rien sur aucune feuille.
J'ai pourtant un Msgbox me disant 9 classeurs regroupés avec 8 feuilles et 169 lignes. Rien n'apparait pourtant dans le doc excel.

Si je réfléchis bien, je devrais avoir 5 (onglets) * 8 (feuilles) que j'ai à regrouper. Donc 40 feuilles devraient se regrouper et être inscrit dans Msgbox. Je pense qu'il y a donc une erreur que je ne décèle pas sur le regroupement de tous les fichiers.

Merci encore de prendre du temps pour m'aider.

PS : En ce qui concerne ton interrogation sur ce point :

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?.

C'est juste que je n'ai pas détaillé la suite des informations.


Pacout



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

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

i = 1
If i = 1 Then
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:=Sheets("Codes articles concernés").Cells(ligne, 1)
ligne = ligne + nbl - l + 1
nbf = nbf + 1

i = 2
ElseIf i = 2 Then
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:=Sheets("Codes articles concernés").Cells(ligne, 1)
ligne = ligne + nbl - l + 1
nbf = nbf + 1

i = 3
ElseIf i = 3 Then
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:=Sheets("Nomenclatures AC").Cells(ligne, 1)
ligne = ligne + nbl - l + 1
nbf = nbf + 1

i = 4
ElseIf i = 4 Then
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:=Sheets("Processus de fabrication").Cells(ligne, 1)
ligne = ligne + nbl - l + 1
nbf = nbf + 1

i = 5
ElseIf i = 5 Then
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:=Sheets("Parc TF").Cells(ligne, 1)
ligne = ligne + nbl - l + 1
nbf = nbf + 1

End If

ActiveWorkbook.Close SaveChanges:=False ' Fermeture du classeur

End If
fic = Dir

nbc = nbc + 1
Wend
fin:
MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
End Sub
0
Réponse 2 / 3
Frenchie83 Messages postés 2254 Statut Membre 339
 
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
0
Réponse 3 / 3
Frenchie83 Messages postés 2254 Statut Membre 339
 
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
0

Discussions similaires

Chemin Logo du site de la Cité de l'espace
Keiios -
blux -

11 réponses