Discussion :

[coralieb]

Bonjour,

Je me permets de vous solliciter et vous remercie par avance de votre aide. je suis novice en vba et bien que j'essaye d'apprendre par moi même, je commence terriblement a manquer de temps pour produire mon étude.

je vous explique mon objectif

je souhaite copier les valeurs des colonnes E:4 à E:46 des onglets "Feuil2" des fichiers situés dans "C:\Documents and Settings\coralieb\Bureau\CA" pour qu'ils se retrouvent dans les colonnes B2 à BZ46 (une colonne pour chaque fichier) dans l'onglet "feuil1" du fichier "macro données ca 2009".

ci dessous ma macro

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
Sub TestCopy()
 
    'Définir une variable qui va représenter un classeur et un onglet à chaque itération.
    Dim Fichier As Workbook, Wb2 As Workbook
    Dim Ws1 As Worksheet, Ws2 As Worksheet
    Dim Cell1 As Range
    Dim Chemin As String
    'Définir une variable qui va représenter une cellule
    Dim Cell2 As Range
 
 
'localiser les données
Chemin = "C:\Documents and Settings\coralieb\Bureau\CA"
FName = Dir(Chemin & "\" & "*.xls")
Set Wb2 = Workbooks("macro données ca 2009.xls")
Set Ws1 = Sheets("Feuil2")
Set Ws2 = Sheets("Feuil1")
Set Cell1 = Range("E4:E46")
Set Cell2 = Range("B2:BZ46")
 
On Error Resume Next
 
  'Boucle sur chaque classeur de l'application Excel
    For Each Fichier In dossier.Files
    NomFichier = Fichier.Name
    Workbooks.Open Filename:=Chemin & "/" & NomFichier
 
    On Error Resume Next
 
     'copier les cellules
With Fichier
    .Ws1.Cell1.Copy
    Wb2.Ws2.Cell2.PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
End With
            Next
 
End Sub

"


merci beaucoup.

[BlueMonkey]

Bonsoir,

En copiant le code ci-dessous dans le classeur macro données ca 2009.xls le code ci-dessous devrait faire ce qui est attendu.

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
Option Explicit
 
Const SearchFolder As String = "C:\Documents and Settings\coralieb\Bureau\CA"
Const FeuilleSource As String = "Feuil2"
Const PlageSource As String = "E4:E46"
Const FeuilleDestination As String = "Feuil1"
 
Sub CopyAllFilesData()
    Call SetDispScreenEventUpdating(False)
 
    Dim strFile As String
    strFile = Dir(SearchFolder)
 
    On Error Resume Next
    Do While strFile <> ""
        Call CopyFileDataE4E46(strFile, ThisWorkbook)
       strFile = Dir
    Loop
 
    On Error GoTo 0
 
    Call SetDispScreenEventUpdating(True)
 
End Sub
 
Sub CopyFileDataE4E46(fName As String, wb As Workbook)
    Dim wbresults As Workbook
    Set wbresults = Workbooks.Open(FileName:=fName, UpdateLinks:=0)
        wbresults.Worksheets(FeuilleSource).Range(PlageSource).Copy
        Dim FirstCol As Long
        With wb.Worksheets(FeuilleDestination)
            FirstCol = .Cells(2, Columns.Count).End(xlToLeft).Column
            If FirstCol < 2 Then FirstCol = 1
            .Cells(2, FirstCol + 1).PasteSpecial Paste:=xlPasteValues
        End With
    wbresults.Close SaveChanges:=False
End Sub
 
Sub SetDispScreenEventUpdating(enable As Boolean)
    Application.ScreenUpdating = enable
    Application.DisplayAlerts = enable
    Application.EnableEvents = enable
End Sub

[coralieb]

merci beaucoup.

alors je viens d'essayer mais cela ne fonctionne pas. Pourtant je n'ai aucun message d'erreur ...
j'ai rajouté un "msgbox" pour voir si la macro tournait et cela s'affiche bien . Je ne sais pas comment l'expliquer.

[Theze]

Bonsoir,

Une autre possibilité. Il te faut exécuter la proc "Recup" (tout en bas). Les commentaires peuvent t'aider à comprendre ce que j'ai voulu faire. Reviens si ça ne va pas :

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
130
131
132
133
134
 
Dim TblVals()
 
Private Sub ConnectCLasseur(ConnectCL As Object, _
                            Fichier As String, _
                            Optional Rs)
 
    Set ConnectCL = CreateObject("ADODB.Connection")
 
    If Not IsMissing(Rs) Then
 
        Set Rs = CreateObject("ADODB.Recordset")
 
    End If
 
    ConnectCL.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & Fichier & ";" & _
              "Extended Properties=""Excel 8.0;HDR=NO;IMEX=2;"""
 
End Sub
 
Sub RecupNoms(Classeur As String, _
              Feuille As String, _
              Plage As String, _
              NumColonne As Integer)
 
    Dim ConnectCL As Object
    Dim Rs As Object
    Dim Champ As Object
    Dim DerCel As Integer
    Dim I As Integer
 
    'ouvre la connexion
    ConnectCLasseur ConnectCL, Classeur, Rs
 
    'ouvre le jeu
    With Rs
 
        .CursorType = 1
        .LockType = 3
        .Open "SELECT * FROM `" & Feuille & "$" & Plage & "` ", ConnectCL
        .MoveFirst
 
        Do While Not .EOF
 
            I = I + 1
 
            TblVals(NumColonne, I) = .Fields(0).Value
 
            .MoveNext
 
        Loop
 
    End With
 
    'ferme la connexion
    ConnectCL.Close
 
    Set Rs = Nothing
    Set ConnectCL = Nothing
 
End Sub
 
Function Fichiers(Chemin As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin)
 
    Do While (Len(Fichier) > 0)
 
        I = I + 1
 
        ReDim Preserve TableauFichiers(1 To I)
 
        TableauFichiers(I) = Fichier
 
        Fichier = Dir()
 
    Loop
 
    Fichiers = TableauFichiers()
 
End Function
 
Sub Recup()
 
    Dim Tbl() As String
    Dim Dossier As String
    Dim NomFeuille As String
    Dim Plage As Range
    Dim I As Integer
    Dim J As Integer
 
    'dossier des fichiers
    Dossier = "C:\Documents and Settings\coralieb\Bureau\CA\"
 
    'feuille où récupérer les valeurs
    NomFeuille = "Feuil2"
 
    'plage des valeurs
    Set Plage = Range("E4:E46")
 
    'stocke dans un tableau le nom des différents fichiers
    Tbl = Fichiers(Dossier)
 
    'redimensionne le tableau où seront stockées les valeurs
    ReDim TblVals(1 To UBound(Tbl), 1 To Plage.Cells.Count)
 
    'boucle sur les fichiers pour récupérer les valeurs
    For I = 1 To UBound(Tbl)
 
        RecupNoms Dossier & Tbl(I), NomFeuille, Plage.Address(0, 0), I
 
    Next I
 
    'inscrit les valeurs en "Feuil1" à partir de "B2" dans le classeur "macro données ca 2009.xls"
    With Workbooks("macro données ca 2009.xls").Worksheets("Feuil1")
 
        For I = 1 To UBound(TblVals, 1)
 
            For J = 1 To UBound(TblVals, 2)
 
                .Cells(J + 1, I + 1) = TblVals(I, J)
 
            Next J
 
        Next I
 
    End With
 
End Sub

Hervé.

[BlueMonkey]

Bonsoir,

cela ne fonctionne pas. Pourtant je n'ai aucun message d'erreur ...

Pour voir les messages d'erreurs, il faut supprimer les lignes 14 et 20 du post #2.

Est-ce que le dossier C:\Documents and Settings\coralieb\Bureau\CA contient
- autre chose que des fichiers Excels ? : si oui, il faudrait retirer ces fichiers.
- le fichier macro données ca 2009.xls ? si oui, il faudrait déplacer ce fichier.

[coralieb]

bonjour,

merci encore pour toutes ces réponses.

Pour infos, ce dossier ne contient pas d'autre fichier, pas même le fichier macro données ca 2009.

Je viens de tester la deuxième macro et cette fois ci j'ai une erreur d'exécution sur " ReDim TblVals(1 To UBound(Tbl), 1 To Plage.Cells.Count)"

[Theze]

Bonsoir,

Sous la ligne de code :

Code :

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

1
2
 
Tbl = Fichiers(Dossier)

de la proc "Recup", inscris cette ligne de code :

Code :

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

1
2
 
MsgBox UBound(Tbl)

Si tu as une erreur sur cette ligne, vérifie bien le chemin de ton dossier où se trouvent tes fichiers Excel car la fonction "Fichiers" ne retourne rien !

Hervé.

[BlueMonkey]

Bonsoir,

Sinon macro v1 corrigée (problème de nom de dossier absolu pour nom de fichier) :

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
Option Explicit
 
Const SearchFolder As String = "C:\Documents and Settings\coralieb\Bureau\CA\"
Const FeuilleSource As String = "Feuil2"
Const PlageSource As String = "E4:E46"
Const FeuilleDestination As String = "Feuil1"
 
Sub CopyAllFilesData()
    Call SetDispScreenEventUpdating(False)
 
    Dim strFile As String
    strFile = Dir(SearchFolder)
 
    'On Error Resume Next
    Do While strFile <> ""
        Call CopyFileDataE4E46(strFile, ThisWorkbook)
       strFile = Dir
    Loop
 
    'On Error GoTo 0
 
    Call SetDispScreenEventUpdating(True)
 
End Sub
 
Sub CopyFileDataE4E46(fName As String, wb As Workbook)
    Dim wbresults As Workbook
    Set wbresults = Workbooks.Open(Filename:=SearchFolder & fName, UpdateLinks:=0)
        wbresults.Worksheets(FeuilleSource).Range(PlageSource).Copy
        Dim FirstCol As Long
        With wb.Worksheets(FeuilleDestination)
            FirstCol = .Cells(2, Columns.Count).End(xlToLeft).Column
            If FirstCol < 2 Then FirstCol = 1
            .Cells(2, FirstCol + 1).PasteSpecial Paste:=xlPasteValues
        End With
    wbresults.Close SaveChanges:=False
End Sub
 
Sub SetDispScreenEventUpdating(enable As Boolean)
    Application.ScreenUpdating = enable
    Application.DisplayAlerts = enable
    Application.EnableEvents = enable
End Sub