Compiler plusieurs onglets excel

**yotman** · 04/04/2016, 20h47

Bonjour,

Je me permets de poser ce problème car je n'arrive pas à trouver la solution avec mes connaissances basiques en VBA.

En gros, je souhaite compiler plusieurs fichiers excel dans un onglet de synthèse contenant la même forme.

J'ai récupérer ce code que j'ai essayé d'adapter mais il ne compile pas toutes les lignes.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Sub MergeSelectedWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim SelectedFiles() As Variant
    Dim NRow As Long
    Dim FileName As String
    Dim NFile As Long
    Dim WorkBk As Workbook
    Dim SourceRange As range
    Dim DestRange As range
    Dim LastRow As Long
 
    ' Create a new workbook and set a variable to the first sheet.
 
    Set SummarySheet = ThisWorkbook.Sheets("Accueil")
 
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Users\Yettou\Desktop\Test"
 
    ' Set the current directory to the the folder path.
    ChDrive FolderPath
    ChDir FolderPath
 
    ' Open the file dialog box and filter on Excel files, allowing multiple files
    ' to be selected.
    SelectedFiles = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
 
    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 3
 
    ' Loop through the list of returned file names
    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        ' Set FileName to be the current workbook file name to open.
        FileName = SelectedFiles(NFile)
 
        ' Open the current workbook.
        Set WorkBk = Workbooks.Open(FileName)
 
        ' Set the cell in column A to be the file name.
 
        LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
        After:=WorkBk.Worksheets(1).Cells.range("A4"), _
                 SearchDirection:=xlPrevious, _
                 LookIn:=xlFormulas, _
                 SearchOrder:=xlByRows).Row
    Set SourceRange = WorkBk.Worksheets(1).range("A4:AM" & LastRow)
 
        ' Set the destination range to start at column A and be the same size as the source range.
        Set DestRange = SummarySheet.range("A" & NRow)
 
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
 
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
 
        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count
 
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
    Next NFile
 
    ' Call AutoFit on the destination sheet so that all data is readable.
    SummarySheet.Columns.AutoFit
End Sub

Je dois copier les données à partir de la ligne 3 (car il a 2 ligne d'en-tète), et les coller à la même ligne (car même structure). le problème est que quand je défini la plage A4:AM, il me prends que la ligne 3 et 4. et je met A10:AM, il me récupere 8 lignes, etc...

Avez vous une idée ?

Merci d'avance

**Philippe Tulliez** · 04/04/2016, 20h52

Bonjour,
Cette contribution Regrouper plusieurs feuilles sur une autre. (2003-2010) t'aidera peut-être

**thebenoit59** · 04/04/2016, 22h25

Je pense, sans tester, que le soucis vient de la ligne suivante :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
After:=WorkBk.Worksheets(1).Cells.range("A4"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row

Essaye un pas à pas pour obtenir là valeur de LastRow qui sera sans doute inférieure à 4.

Essaye de remplacer par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 LastRow = WorkBk.Worksheets(1).Cells.Find ("*",,,,xlbyrows,xlprevious).row

**yotman** · 05/04/2016, 09h16

Bonjour,

merci pour vos réponses rapides.

Effectivement, je pense que le problème vient de :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
        after:=WorkBk.Worksheets(1).Cells.Range("A4"), _
                SearchDirection:=xlPrevious, _
                 LookIn:=xlFormulas, _
                 SearchOrder:=xlByRows).Row
    Set sourceRange = WorkBk.Worksheets(1).Range("A4:AM" & LastRow)

Je pense qu'il faut changer le A4 de la plage A4:AM par la dernière colonne de chaque fichier.

Car avec la definition de cette plage, il va me prendre toutes les données jusqu'à la ligne A4, mais moi je veux qu'il me trouve la derniere ligne pour chaque fichier, pour éviter d'avoir des lignes vides suite à la definition d'un chiffre au hazard.

Je ne sais pas si je suis clair ?

Merci beaucoup

**thebenoit59** · 05/04/2016, 09h20

J'ai bien compris ton soucis, as-tu essayé de remplacer ton LastRow par le code proposé ?

**RyuAutodidacte** · 05/04/2016, 10h58

Bonjour yotman,
pourrais tu mettres un exemple avec de fausses données sur un fichier xlsx avec ce que tu as au départ et sur une feuille le résultat que tu veux obtenir.
j'ai besoin de visualiser
sinon il y a ce post qui pourrait peut être t'inspirer : http://www.developpez.net/forums/d15...s/#post8578900

**yotman** · 05/04/2016, 11h25

RyuAutodidacte, tu trouves ci-joint le fichier compilation et les 2 fichiers que je dois compiler.

Merci

**RyuAutodidacte** · 05/04/2016, 12h05

Donc en fait tu veux récupérer toutes les feuilles ou seulement les feuilles se nommant hoja1 du fichier 1 et 2 dans hora1 du fichier compilation ?

Edit : heureusement que j'avais dit xlsx les fichiers, du coup je les ai ouverts en désactivant les macro

**yotman** · 05/04/2016, 14h25

RyuAutodidacte, oui je veux récupérer les données de l'onglet PA (hoja 1), et les insérer dans l'onglet PA (hoja 1) du fichier compilation. Car tous les fichiers ont la meme structure.

Pour faire le test, il faut supprimer le hoja2, car je t'ai envoyé le fichier compilation sans un onglet.

**thebenoit59** · 05/04/2016, 14h31

Je vais me répéter, mais si tu remplaces ton LastRow par celui que j'ai proposé, ton code devrait fonctionner ...

**yotman** · 05/04/2016, 14h33

thebenoit59, non ça ne fonctionne pas malheuresement.

**Philippe Tulliez** · 05/04/2016, 15h01

Bonjour,
As-tu regardé le lien que j'ai déposé dans ma réponse d'hier à 20h52 ?
Cela fait exactement ce que tu souhaites faire sauf que les titres (étiquettes de colonnes) sont sur une ligne.

**yotman** · 05/04/2016, 15h24

Philippe Tulliez, oui j'ai regardé, mais votre code regroupe les onglets du meme fichier, moi je regroupe des onglets d'autres fichiers.

Malheuresement, je n'ai pas des competences en VBA donc je ne peux modifier ton code.

**Philippe Tulliez** · 05/04/2016, 15h30

Bonjour,

Philippe Tulliez, oui j'ai regardé, mais votre code regroupe les onglets du meme fichier, moi je regroupe des onglets d'autres fichiers.

Alors tu n'as pas lu cette contribution jusqu'au bout. La procédure est totalement transparente et indépendante des classeurs et j'ai donné un exemple avec un fichier compressé contenant des classeurs différents.

**yotman** · 05/04/2016, 15h44

Ok super, ton code fait exactement ce que je veux faire. Le petit souci est que : il ne prend pas en compte les fichiers xlsm, et je ne vois pas à quel moment il faut faire la modification.

J'ai vu que ce problème a été remonté dans ta contribution.

Le code s'arrete ici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Elem = 0 To UBound(FileList)

Merci

**Philippe Tulliez** · 05/04/2016, 16h02

Bonjour,

Ok super, ton code fait exactement ce que je veux faire. Le petit souci est que : il ne prend pas en compte les fichiers xlsm, et je ne vois pas à quel moment il faut faire la modification.

A première vue, le problème des classeurs suffixé xlsm qui ne sont pas pris en compte provient de la ligne 6 de la procédure nommée FileListInFolder se trouvant dans le fil #3.
En effet pour cet exemple je n'ai tenu compte que des classeurs suffixés xls

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If Right(FileName, 4) = ".xls" Then

Je n'ai pas le temps de regarder cela maintenant mais une petite modification en utilisant soit Instr, soit en comparant les cinq caractères de droite au lieu des quatre devrait suffire (Mis volontairement au conditionnel).

J'ai vu que ce problème a été remonté dans ta contribution.
Le code s'arrete ici : Elem = 0 To UBound(FileList)

Cela m'a échappé, je vais regarder cela ce soir et j'apporterai la correction.

**RyuAutodidacte** · 05/04/2016, 16h22

re,
je te propose aussi une solution ou tu place tes fichiers pour la compilation dans un sous dossier (ça me permettra de voir si mon code marche correctement (lit bien les commentaires dans le code pour les petites modif)
tu auras : ton fichier maitre => le sous dossier lambda (à toi de le créer -> modif dans le code) et à l'interieur tes fichiers à compiler

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Public sD As Variant, S As String 'à mettre tout en haut avant le 1er Sub
 
Sub Compilations()
Dim Rep$, Fichier$, sD_Courant$, Choix_sD$, Rw As Range, R_Rw As Long, C_Rw As Integer
 
MsgBox Hoja1.UsedRange.Rows.Count
Hoja1.UsedRange.Select
 
    Application.ScreenUpdating = False
 
    Drt = ThisWorkbook.Path   'code permettant de déterminer quel type de séparation nous avons pour le chemin dans un répertoire
    If InStr(Drt, "\") Then sep = "\" Else sep = ":"   ' "\" => pour PC   -   ":" => pour MAC
 
    Entete& = 2 'Choisir le nombre de ligne pour l'entête => Entête des fichiers sources se trouvant dans le sous-dossier => pour récup. données
    sD_Courant$ = "Macompil" 'mettre le sous-dossier utilisé couramment
 
    Choix_sD = MsgBox("Voulez-vous utiliser le sous-dossier courant", vbYesNo) 'sD pour "sous-dossier"
 
    If Choix_sD = vbYes Then sD = sD_Courant Else sD = Application.InputBox("Mettre le nom du sous-dossier", "SOUS_DOSSIER")
 
On Error Resume Next
    Dir (ThisWorkbook.Path & sep & sD & sep)
 
    If sD = False Then
        S = "Annulation de la copie"
        GoTo Reponse
    ElseIf sD = "" Then
        S = "Aucun nom de sous-dossier entré"
        GoTo Reponse
    ElseIf Err.Number <> 0 Then
        S = "Le dossier '" & sD & "' n'existe pas"
        Err.Clear: On Error GoTo 0: GoTo Reponse
    Else
        S = "La MAJ du fichier est OK" & vbCrLf & "Sous-dossier choisi : " & sD
    End If
 
    Application.EnableEvents = False
    Rep = ThisWorkbook.Path & sep & sD & sep
    Fichier = Dir(Rep)
 
    Do While Fichier <> ""
        Application.EnableEvents = False
        Workbooks.Open Workbooks(ActiveWorkbook.Name).Path & sep & sD & sep & Fichier
        Application.EnableEvents = True
        With Sheets("PA")
            Set Rw = .UsedRange.Resize(.UsedRange.Rows.Count - Entete).Offset(Entete)
            R_Rw = Rw.Rows.Count
            C_Rw = Rw.Columns.Count
            MsgBox R_Rw & "   -   " & C_Rw
            Hoja1.UsedRange.Resize(R_Rw, C_Rw).Offset(Hoja1.Range("A" & Rows.Count).End(xlUp).Row).Value = Rw.Value 'dans Offset(Hoja1.Range("A" & Rows.Count) remplacer A par la colonne référentes aux infos pour avoir la dernière ligne non utilisé
        End With
 
        Set Rw = Nothing
        Application.Workbooks(Fichier).Close False
        ThisWorkbook.Activate
 
        Fichier = Dir
    Loop
 
    Application.ScreenUpdating = True
 
Reponse:
    MsgBox S
    Application.Goto Cells(1), True
 
End Sub

PS Philippe Tulliez : j'ai voulu faire marcher votre version via le lien donné, mais malheureusement j'ai pas l'impression que cela marche sur Mac !? Qu'en est il ??

Edit : le code viens d'être corrigé concernant la partie avec Drt

**Philippe Tulliez** · 05/04/2016, 16h49

Bonjour,

PS Philippe Tulliez : j'ai voulu faire marcher votre version via le lien donné, mais malheureusement j'ai pas l'impression que cela marche sur Mac !? Qu'en est il ??

Je n'ai pas d'expérience avec le MAC et n'ai pas encore reçu de retour me disant que cela ne fonctionne pas avec le mac.
Cependant sans plus d'explications, il est difficile d'analyser et d'isoler un problème.
Quelle procédure ne fonctionne pas ?
à quelle ligne de cette procédure et quel est le message d'erreur renvoyé (n° et texte de l'erreur)

**Philippe Tulliez** · 05/04/2016, 16h55

Bonjour,
Pour pouvoir utiliser les fichiers suffixés xls, xlsx et xlsm, il y a lieu de remplacer la ligne 6 par la ligne 7 de la procédure nommée FileListInFolder
Attention, faute de temps, je n'ai pas pu tester avec un fichier xlsm. J'ai placé dans le même répertoire des fichiers xlsx et xls et cela a fonctionné.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Function FileListInFolder(StrPath As String) As Variant
 Dim FileName As String, Elem As Long, FileList() As String
 If Right(StrPath, 1) <> "\" Then StrPath = StrPath & "\"
 FileName = Dir(StrPath)
 Do While FileName <> ""
  'If Right(FileName, 4) = ".xls" Then
  If InStr(LCase(FileName), "xls") Then
   ReDim Preserve FileList(Elem): FileList(Elem) = FileName: Elem = Elem + 1
  End If
  FileName = Dir
 Loop
 FileListInFolder = FileList
End Function