Macro qui fonctionne en pas à pas (F8) mais pas en une fois.
Bonjour,
La macro que j'ai fonctionne en pas à pas (c'est à dire en appuyant sur F8)= ligne par ligne) mais pas en la lançant d'un coup à partir d'un fichier générateur.
Son but :
- Parcourir tous les fichiers d'un dossier renseigné en début de macro
- Parcourir tous les onglets de ces fichiers
- Y chercher le mot "annulation" (pour trouver la ligne d’entête du fichier - qui n'est pas forcément toujours sur la même ligne)
- puis parcourir toutes les lignes inférieures à la ligne d’entête.
- Chercher si la colonne "annulation" a des occurrences
- copier la ligne entière vers un fichier vierge
Code:
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
| Chemin = InputBox("saisir le chemin", "Saisie du répertoire")
If Right(Chemin, 1) <> "\" Then
Chemin = Chemin & "\"
End If
'appel de la fonction avec le chemin du dossier (adapter...)
Tablo = RecupFichiers(Chemin)
'si au moins un fichier trouvé...
If Not (Not Tablo) Then
'Workbooks.Add
Set Fichier_Final = Workbooks.Add
Ligne_Fichier_Final = 2
For i = 1 To UBound(Tablo)
'ouvre le classeur...
Set Cls = Workbooks.Open(Chemin & Tablo(i), UpdateLinks:=False)
'parcours sa collection de feuilles...
For Each Feuille In Cls.Worksheets
Set c = Feuille.Range("A1:ZZ10").Find("Annulation", LookIn:=xlValues)
If Not c Is Nothing Then
For Ligne_Fichier_Source = c.Row + 1 To Feuille.Range("A" & Rows.Count).End(xlUp).Row
If Feuille.Cells(Ligne_Fichier_Source, c.Column) <> "" Then
Cls.Feuille.Range(Rows(Ligne_Fichier_Source), Rows(Ligne_Fichier_Source)).Copy
Fichier_Final.Sheets(1).Cells(Ligne_Fichier_Final, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Ligne_Fichier_Final = Ligne_Fichier_Final + 1
End If
Next Ligne_Fichier_Source
End If
Next Feuille
'referme le classeur
Application.CutCopyMode = False
Cls.Close SaveChanges:=False
Next i
End If
Application.DisplayAlerts = False
End Sub
Function RecupFichiers(Chemin As String) As String()
Dim Tbl() As String
Dim Fichier As String
Dim i As Integer
'seulement les fichiers .xlsx
Fichier = Dir(Chemin & "*.xlsx")
Do While (Len(Fichier) > 0)
i = i + 1
ReDim Preserve Tbl(1 To i)
Tbl(i) = Fichier
Fichier = Dir()
Loop
RecupFichiers = Tbl()
End Function |
Vous avez une idée d’où vient le problème?
