Hi there,
It's been a while I have been trying to build a macro to concatenate around 300 excel files...I found on the web some parts of the code, but as a beginner I am struggling to arrange all of this. But I am improving each day..(hopefully)
In one foler I have all my extracts file : cell(a1) is the date of the extract, then you find coloumn (c7:c26) all the stock names, and column (D7:D26) all the close prices.
My objective is to create a macro which would give one worksheet:
Column A2:A3XX : all the dates of all my extracts
Column B1 to U1 : the 20 stock names
Column B2 to U2: the 20 close prices for each stock for on date
Column B3 to U3 : the close prices for each stock for the following day
etc...
I know I can download this directly but I actually need to extract the prices fronm those extracts, provided by the exchange directly.
Below an attempt of code. The code reads all the files in the folder colled "Clean extract" and get the prices.
The first problem is that the prices are copied and pasted, but in columns and I would need them on a line (transpose).
The second problem is to have the transposed prices copied on each line corresponding to each date, and so on, on each day.
I hope I have been clear for you guys to understand the problems.
Thanks for your help.
=========================================================
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
=========================================================
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
It's been a while I have been trying to build a macro to concatenate around 300 excel files...I found on the web some parts of the code, but as a beginner I am struggling to arrange all of this. But I am improving each day..(hopefully)
In one foler I have all my extracts file : cell(a1) is the date of the extract, then you find coloumn (c7:c26) all the stock names, and column (D7:D26) all the close prices.
My objective is to create a macro which would give one worksheet:
Column A2:A3XX : all the dates of all my extracts
Column B1 to U1 : the 20 stock names
Column B2 to U2: the 20 close prices for each stock for on date
Column B3 to U3 : the close prices for each stock for the following day
etc...
I know I can download this directly but I actually need to extract the prices fronm those extracts, provided by the exchange directly.
Below an attempt of code. The code reads all the files in the folder colled "Clean extract" and get the prices.
The first problem is that the prices are copied and pasted, but in columns and I would need them on a line (transpose).
The second problem is to have the transposed prices copied on each line corresponding to each date, and so on, on each day.
I hope I have been clear for you guys to understand the problems.
Thanks for your help.
=========================================================
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
=========================================================
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
