2 pièce(s) jointe(s)
Probleme Concatenation VBA
Bonjour tout le monde
Cela fait plusieurs que j'essaie de creer une macro afin de concatener pres de 300 fichiers xls..J'ai trouve quelques morceaux de codes que j'ai essaye d'arranger mais je suis bloque. Les debuts en VBA sont decidements pas evidents.
Les 2 premiers fichiers en PJ sont deux exemples des 300 fichiers que j'essaie de compiler. Ils ont tous le meme format et ce sont les extracts dont je fais allusion plus loin.
L'objectif est ici d'obtenir un tableau dans lequel il y aurait dans la premiere colonne l'ensemble des dates (dans les extracts = Cell(A,1)), puis le prix (dans les extracts "Close" Cell(E6)) pour chacune des 20 societes (Nestle, Novartis...Lonza). Ainsi pour chaque journee, nous aurions les prix de cloture des 20 societes sur une seule ligne. Les prix de cloture sont facilement telechargeables mais j'ai en fait besoin d'autres info telles aue F.Float etc, il me suffira ensuite d'adapter le code que je serai parvenu a faire grace a vous.
Ci-dessous un debut de code. Le code lit l'ensemble des fichiers presents dans un dossier "Clean Extract" et tente de recuperer les prix (colonne C des extracts).
Mon premier probleme est que les donnees sont copiees, mais en colonne. J ai essaye de trouver une variante de TargetRange.Cells(1, 1).CopyFromRecordset rsData pour ajouter une fonction transpose mais je n'ai pas reussi.
Un second probleme serait egalement d'arriver a mettre sur une premiere ligne les noms des entreprises (de B1 a U1) puis les prix correspondants sur la lignes du dessous (C2 a U2) avec la date en C1. Et ainsi de suite pour tous les extracts presents dans le meme dossier. (j'en ai pres de 300).
J'espere avoir ete suffisament clair, merci d'avance a ceux qui sauront m'aider.
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
69
70
71
| Option Explicit
' Copy a range from all files in a folder
' This example will copy a range from all files that are in the folder C:\Users\Ron\Test
' It will add a new worksheet to your workbook with all the data in it.
Sub GetData_Example6()
Dim MyPath As String
Dim FilesInPath As String
Dim sh As Worksheet
Dim MyFiles() As String
Dim Fnum As Long
Dim rnum As Long
Dim destrange As Range
MyPath = "H:\SMI Index Compo Watch\201007\CleanExtract" ' <<<< Change
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.ScreenUpdating = False
'Add worksheet to the Activeworkbook and use the Date/Time as name
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mm-yy h-mm-ss")
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
'Find the last row with data
rnum = LastRow(sh)
'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")
'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData MyPath & MyFiles(Fnum), "", "D7:D26", destrange, True, True
Next
End If
'setdatextract
CleanUp:
Application.ScreenUpdating = True
End Sub |
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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
| Option Explicit
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub |
