Discussion :

[superstarz]

Bonjour,

J'ai une macro qui parcours un répertoire et qui collecte l'ensemble des 2ème sheet de chaque fichier pour le copier/coller dans un onglet "database".


Cela fonctionne sauf que parfois, 60% du temps, la macro ne s'exécute pas jusqu'au bout.
Pas tous les fichiers sont ouverts/copier.

Je n'arrive pas à debugger cela,
Je n'arrive non plus pas à compremdre l'ordre d'ouveture des fichiers, ce n'est pas par ordre alphabétique.

Avez-vous des idées ?

[riaolle]

Bonjour,
Ca va être difficile de corriger un code, sans voir le code ...

[superstarz]

Je ne voulais pas le faire car je suis sur le poste d'une banque. Je voulais simplement obtenir des astuces pour tenter de debugger ce truc là.

J'ai quand même extrait l

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
68
69
70
 
Sub Fusion()
 
Dim principal As ThisWorkbook
Dim repertoire As String, fichier As String
Dim row As Integer
    'Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    'Sheets("Consolidate").Activate
    'repertoire = Cells(8, 2)
    Sheets("Database").Activate
    Application.ScreenUpdating = False
    Set principal = ThisWorkbook
    Sheets("Database").Activate
    'Selectionne toutes les cellules de la feuille
    Cells.Select 'on sélectionne tout
   Range("A2:K650000").Select 'On sélectionne que ce qui concerne les données copiées
    'Supprime toutes les cellules et les décales vers le haut
    Selection.Delete
    Application.DisplayAlerts = False
    repertoire = "***"
    ChDir repertoire
    fichier = Dir("*.xlsm")
    Do While fichier <> ""
        If fichier <> principal.Name Then
            Workbooks.Open fichier
            On Error GoTo suivant
            With Sheets(2)
                On Error GoTo 0
                On Error Resume Next
                If .AutoFilterMode Then
                    .Cells.AutoFilter
                End If
                Sheets(2).Select
                    'row = Range("A" & Rows.Count).End(xlUp).row
                    Do While Cells(row, 7) <> "" 'Count last cell
                        row = row + 1
                    Loop
                    Range("A2:I" & row).Select
                    'MsgBox fichier & "Has opened"
                    'MsgBox row & " lignes"
                    'Range(Selection, Selection.End(xlDown)).Select
                    'Range(Selection, Selection.End(xlToRight)).Select
                    Selection.Copy
                    ActiveWorkbook.Close False
                    principal.Activate
                    Sheets("Database").Select
                    Range("A65000").End(xlUp).Offset(1).Select
                    ActiveSheet.Paste
                    'Selection.End(xlDown).Select
                    'ActiveCell.Offset(1, 0).Select
                    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    ':=False, Transpose:=False
                    Application.CutCopyMode = False
                    ActiveWorkbook.Save
                    'MsgBox fichier & "Has opened"
                    Workbook.Open (fichier)
                    fichier = Dir
            End With
            'ActiveWorkbook.Close False
        End If
suivant:
        If Err.Number = 9 Then MsgBox "Pas de feuille ""Data"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
        'fichier = Dir
    Loop
    Workbook_Open 'Close all windows
    Formula_DB 'Tirer les formules dans Database
    'Application.Calculation = xlCalculationAutomatic
End Sub

[riaolle]

Plusieurs remarques :
- Essaie d'alléger un peu ton code : tu as des lignes en double.

Code :

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

1
2
3
4
5
6
7
8
Application.EnableEvents = False
    Application.ScreenUpdating = False
    'Sheets("Consolidate").Activate
    'repertoire = Cells(8, 2)
    Sheets("Database").Activate
    Application.ScreenUpdating = False
    Set principal = ThisWorkbook
    Sheets("Database").Activate

Se résume par

Code :

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

1
2
3
4
Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set principal = ThisWorkbook
    Sheets("Database").Activate

- Evite d'utiliser Select/Activate/Selection/ActiveSheet etc ...
Plutôt que

Code :

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

1
2
3
4
5
6
7
8
    Sheets("Database").Activate
    Set principal = ThisWorkbook
    Sheets("Database").Activate
    'Selectionne toutes les cellules de la feuille
    Cells.Select 'on sélectionne tout
   Range("A2:K650000").Select 'On sélectionne que ce qui concerne les données copiées
    'Supprime toutes les cellules et les décales vers le haut
    Selection.Delete

Ecris

Code :

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

1
2
    Set principal = ThisWorkbook
    Sheets("Database").Range("A2:K650000").Delete

Au passage sélectionner toutes les cellules pour tout de suite après restreindre la sélection à quelques cellules, ne sert pas à grand chose.
- Pour trouver la dernière ligne non vide d'une feuille : pas de boucle While, mais :

Code :

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

rowN = Sheets("ma feuille").Range("A" & Rows.Count).End(xlUp).Row

Au passage = row est un nom réservé, tu ne peux donc pas l'utiliser comme nom de variable !!!
- On Error Resume Next, c'est pas très bon : si tu as une erreur quelque part tu ne la verras pas et tu ne pourras pas la corriger. Enlève ceci et regarde où se trouvent tes erreurs (et quels types d'erreurs tu obtiens).
- Pour copier, utiliser la syntaxe suivante :

Code :

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

Sheets("feuille source").Range("A1").Copy destination:=Sheets("feuille destination").Range("A1")

En plus cela t'évitera d'utiliser les Select/Selection etc ...

[MYWIAM]

Bonjour,

je cherche exactement (depuis 2 jours) le même type de macro . .. mais en vain (je suis totalement novice sur VBA)

j'explique mon défi :
j'ai un dossier qui contient 264 fichiers excel (semaine1dép1, semaine1dép2,...., semaine1dép8, ...... semaine52dép8). Chaque fichier contient un tableau qui a la même configuration sur tous les autres fichiers mais avec des données différentes et un nombre de lignes différent et j'aimerais fusionner tout ça en un seul tableau excel (sans le faire manuellement) : que les données du 1er fichier "semaine1dép1" au 264éme fichier "semaine52dép8" soient regroupées de bout en bout.
pour précision : l’entête du tableau dans tous les fichier occupe deux lignes : de la cell E18 à la cell AH19

J'ai lu la macro de superstarz et les modif de riaolle mais je n'arrive pas à tout faire fonctionner.

Pourriez-vous m'aider?

[riaolle]

Bonjour,
MYWIAM, si tu n'arrives vraiment pas à faire marcher ton code, tu ferais mieux d'ouvrir une nouvelle discussion où tu nous montres ton code, tu nous dis où apparaîssent les erreurs. Si tu as un message d'erreur, tu nous dis lequel et où dans ton code.