Discussion :

[julie.b]

Bonjour à tous,
Je cherche depuis un moment un code me permettant de copier une feuille appelée "corrections" présente dans 70 fichiers excel du même dossier dans une seule feuille d'un nouveau fichier en insérant une ligne entre chaque élément copié et une colonne avec l'origine des données (nom du fichier). Après plusieurs essais infructueux, alors que cette question revient assez souvent dans les forums, j'espère trouver de l'aide ici...
Bon appétit!

[Invité]

bonjour,
si tu nous donnais au mois la partie du code qui coince, voir un fichier ou deux avec des données bidonnées?
on pourrait mieux te venir en aide!

[Marc-L]

Bonjour,

vu le sujet récurrent, il y a ce qu'il faut par exemple dans le forum Contribuez …

[julie.b]

Bonjour,
Voilà ce que j'ai essayé, sachant que je ne maîtrise par vraiment le VBA...
Merciessai_compil.rar

[Invité]

test ça

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
Sub test()
 Dim f As String
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim Rep
 Dim ActiveName
 Rep = ActiveWorkbook.Path & "\"
 f = Dir(ActiveWorkbook.Path & "\*.xls*")
 ActiveName = ActiveWorkbook.Name
 Set wb = Workbooks.Add
 Set ws = wb.Sheets(1)
 ws.Name = "corrections"
 ws.Range("a1:h1") = Array("Fichier", "annee", "produit", "amm", "qte", "unite", "rq", "correction")
 While f <> ""
 If f <> ActiveName Then GetData ws, Rep, f
 f = Dir
 Wend
 MsgBox "Fin"
 End Sub
 
 
Public Sub GetData(Feuille As Worksheet, Rep, fichier As String)
Dim Con As Object
Dim Rs As Object
Set Con = CreateObject("ADODB.Connection")
Con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Rep & fichier & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
Set Rs = CreateObject("ADODB.Recordset")
 
Sql = "SELECT top 1   * FROM [corrections$];"
Rs.Open Sql, Con, 0, 1, 1
Sql = "SELECT  '" & fichier & "' As fichier,"
For i = 0 To Rs.Fields.Count - 1
    Sql = Sql & "IIf(IsDate([" & Rs.Fields(i).Name & "]) "
    Sql = Sql & "And InStr([" & Rs.Fields(i).Name & "],'/')<>0,"
    Sql = Sql & "Format([" & Rs.Fields(i).Name & "],'yyyy-mm-dd hh:mm:ss'),"
    Sql = Sql & "IIf(IsNumeric([" & Rs.Fields(i).Name & "]),"
    Sql = Sql & "CDbl([" & Rs.Fields(i).Name & "]),[" & Rs.Fields(i).Name & "])),"
Next
Sql = Left(Sql, Len(Sql) - 1) & " FROM [corrections$];"
Rs.Close
Rs.Open Sql, Con, 0, 1, 1
Dim derL As Long
derL = Feuille.Cells(Feuille.Cells.Rows.Count, 1).End(xlUp).Row + 1
If derL > 2 Then derL = derL + 1
If Not Rs.EOF Then
 
Feuille.Cells(derL, 1).CopyFromRecordset Rs
 
End If
Rs.Close
Set Rs = Nothing
Con.Close
Set Con = Nothing
 
End Sub

[julie.b]

Super!
Je ne comprends pas tout mais çà marche. Je ne pensais pas qu'il serait si long. Je regarderai le code de plus près plus tard.
Un énorme merci!
Bonne après-midi!