Discussion :

[nhug1]

Bonjour!

Je me permet de vous montrer mon petit bout de code qui me pose problème

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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
Sub BoucleFichiers()
 
    Dim Chemin As String, Fichier As Variant
    Dim Tbl()
    Dim seldossier As String
    Dim D As Object
    Dim MonRepertoire As String, fso As Object, f As Object, i As Integer
    Dim c As Range
    Dim v As Long
    Dim derniere
    Dim source As String
    Dim fichierconsolide As String
 
Chemin = ActiveWorkbook.Path
 
 Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.InitialFileName = Defaut
If .Show = -1 Then
'Seldossier contient le chemin d'accès au répertoir à utiliser
seldossier = fd.SelectedItems(1) & "\"
End If
End With
 
Set fd = Nothing
 
    Set Workbook = Application.Workbooks.Add
 
    With Workbook
            .SaveAs Filename:=Chemin & "\" & "Final-Recos-CIB-BP2S 31082015"
            .Activate
            fichierconsolide = ActiveWorkbook.Name
            Workbooks(fichierconsolide).Activate
            Workbooks(fichierconsolide).Close
    End With
 
 
 
    MsgBox ActiveWorkbook.Name & "   controle1"
Fichier = Dir(seldossier & "*.xlsx")
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 
 MonRepertoire = seldossier
 
 
 
 For Each f In fso.GetFolder(MonRepertoire).Files
 
 
 Workbooks.Open MonRepertoire & f.Name
 Workbooks(f.Name).Activate
 
 MsgBox ActiveWorkbook.Name & "   contrôle fichier actif dans la boucle for each"
 derniere = Range("A1").End(xlDown).Address
 source = f.Name
 MsgBox ("fichier source   ") & source
 
 
 
  With ActiveSheet
            Set PlageDeRecherche = Range("A3:A" & [A65536].End(xlUp).Row)
  End With
 
     'Recherche dans le fichier la première cellule contenant le mot clé
     Set trouve = PlageDeRecherche.Find("*", , xlValues, xlWhole)
 
 
     If trouve Is Nothing Then
 
        MsgBox "'" & requete & "' n'est pas présent dans " & PlageDeRecherche.Address(0, 0)
 
    Else
 
        adr = trouve.Address
        'efface toutes les données du tableau
        Erase Tbl
        'Remet la variable d'incrémentation à 0
        i = 0
        'boucle pour récupérer les numéros de ligne dans le tableau
        Do
 
            i = i + 1
 
            ReDim Preserve Tbl(1 To i)
 
            Tbl(i) = trouve.Row
 
            Set trouve = PlageDeRecherche.FindNext(trouve)
 
        Loop While adr <> trouve.Address
 
        With Workbook
        Workbooks.Open Filename:=(Chemin & "\" & "Final-Recos-CIB-BP2S 31082015")
        Workbooks(fichierconsolide).Activate
        End With
 
 For i = 1 To UBound(Tbl)
 
 Workbooks(source).Sheets(1).Tbl(i).EntireRow.Copy Destination:=Workbooks(fichierconsolide).Sheets(1).[A1].Offset(i, 0):
 
 Next i
 
    Workbooks(source).Save
    Workbooks(source).Close
 
 
End If
 
Next f
    Workbooks(fichierconsolide).Save
    Workbooks(fichierconsolide).Close
 
 
End Sub

l'erreur se situe sur Workbooks(source).Sheets(1).Tbl(i).EntireRow.Copy Destination:=Workbooks(fichierconsolide).Sheets(1).[A1].Offset(i, 0):.

Pourtant lorsque je passe le curseur sur source et fichierconsolide tout paraît bon...

Si vous avez des idées ou des corrections j'en serais très heureux!


Merci à vous!

[PMO2017]

Bonjour,

Le problème survient (peut être) de l'absence de la propriété Rows

Code :

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

Workbooks(source).Sheets(1).Rows(Tbl(i)).EntireRow.Copy Destination:=Workbooks(fichierconsolide).Sheets(1).[A1].Offset(i, 0)

[nhug1]

Effectivement! Bien joué c'était exactement ça!

Entre temps j'avais trouvé (j'ai pas vu le mail d'avertissement de réponse sur mon iphone) je te remercie du temps que tu as passé pour pointer du doigt mon erreur! :-)

Je me permets de passer le problème en résolu, de te mettre un joli pouce vert et de mettre mon code fini pour qui voudra!

Mon programme permet de sélectionner un dossier contenant des .xlsx (ou autre hein! il suffit de changer l'extension) et de les consolider en un seul fichier. J'ai néanmoins enlevé quelques lignes de mon code pour des raisons de confidentialité (milieu bancaire oblige) mais il est complètement fonctionnel!

Je tiens encore une fois à remercier la communauté développez.net qui montre que si on arrive pas les mains dans les poches on a toujours de très (très) bon conseils.

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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
 
 
Sub BoucleFichiers()
 
    Dim Chemin As String, Fichier As Variant
    Dim Tbl()
    Dim seldossier As String
    Dim D As Object
    Dim MonRepertoire As String, fso As Object, f As Object, i As Integer
    Dim c As Range
    Dim v As Long
    Dim derniere
    Dim source As String
    Dim fichierconsolide As String
    Dim PremiereDisponible
 
Chemin = ActiveWorkbook.Path
 
 Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.InitialFileName = Defaut
If .Show = -1 Then
'Seldossier contient le chemin d'accès au répertoir à utiliser
seldossier = fd.SelectedItems(1) & "\"
End If
End With
 
Set fd = Nothing
 
    Set Workbook = Application.Workbooks.Add
 
    With Workbook
            .SaveAs Filename:=Chemin & "\" & "choisir son nom de fichier"
            .Activate
            fichierconsolide = ActiveWorkbook.Name
            Workbooks(fichierconsolide).Activate
            Workbooks(fichierconsolide).Close
    End With
 
 
 
 
Fichier = Dir(seldossier & "*.xlsx")
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 
 MonRepertoire = seldossier
 
Application.ScreenUpdating = False
 
 For Each f In fso.GetFolder(MonRepertoire).Files
 
 
 Workbooks.Open MonRepertoire & f.Name
 Workbooks(f.Name).Activate
 
 
 derniere = Range("A1").End(xlDown).Address
 source = f.Name
 
 
 
 
  With ActiveSheet
            Set PlageDeRecherche = Range("A2:A" & [A65536].End(xlUp).Row)
  End With
 
     'Recherche dans le fichier la première cellule contenant le mot clé
     Set trouve = PlageDeRecherche.Find("*", , xlValues, xlWhole)
 
 
     If trouve Is Nothing Then
 
        MsgBox "'" & requete & "' n'est pas présent dans " & PlageDeRecherche.Address(0, 0)
 
    Else
 
        adr = trouve.Address
 
        bonneadr = Range(adr).Offset(-1, 0).Address
 
        'efface toutes les données du tableau
        Erase Tbl
        'Remet la variable d'incrémentation à 0
        i = 0
        'boucle pour récupérer les numéros de ligne dans le tableau
        Do
 
            i = i + 1
 
            ReDim Preserve Tbl(1 To i)
 
            Tbl(i) = trouve.Row
 
 
            Set trouve = PlageDeRecherche.FindNext(trouve)
 
        Loop While bonneadr <> trouve.Address
 
        With Workbook
        Workbooks.Open Filename:=(Chemin & "\" & "choisir son nom de fichier")
        Workbooks(fichierconsolide).Activate
        End With
 
        PremiereDisponible = Range("A65536").End(xlUp).Address
 
 
For i = 1 To UBound(Tbl)
 
 Workbooks(source).Sheets(1).Rows(Tbl(i)).EntireRow.Copy Destination:=Workbooks(fichierconsolide).Sheets(1).Range(PremiereDisponible).Offset(i, 0):
 
Next i
 
    Workbooks(source).Save
    Workbooks(source).Close
    Workbooks(fichierconsolide).Save
    Workbooks(fichierconsolide).Close
 
 
End If
 
Next f
 
Application.ScreenUpdating = True
 
MsgBox ("consolidation effectuée")
 
 
End Sub