I am using ADO to copy a range (10 rows by 1 column) from all files in a specified folder into a worksheet in the active workbook. My understanding of ADO is a little hazy, I copied some code from a website I found and have managed to tweak it a little as I want the data in the active workbook to be transposed, i.e 1 row by 10 columns. This works but there is a niggle in that the last file's data is copied across both as 10x1 and 1x10. I can quite easily manually delete the nine superfluous cells, but could somebody here kindly explain to me why it does this?
VBA:
' Copies a specified range from all files in a specified folder.
' A new worksheet will be add to the active workbook with all the data in it.
' Also needs GetData macro.
Sub GetData()
Dim MyPath As String
Dim FilesInPath As String
Dim sh As Worksheet
Dim MyFiles() As String
Dim Fnum As Long
Dim cnum, rnum As Long
Dim destrange As Range
' This is the directory from which data are extracted.
MyPath = "H:\vba" 'TRR 2005 Returns"
' 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 & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.ScreenUpdating = False
' Add worksheet to the Active workbook & name it
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "TRR Excel data"
' 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
rnum = 1
cnum = 1
' Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
' Create the destination cell address
Set destrange = sh.Cells(rnum + 1, cnum)
' Move along one column for next file's data.
rnum = rnum + 1
' Get the cell values and copy it in the destrange.
GetData MyPath & MyFiles(Fnum), "SCHOOL DATA", "B1:B11", destrange, False
Next
End If
CleanUp:
Application.ScreenUpdating = True
End Sub
Display More
This is the GetData function:
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
sourceRange As String, TargetRange As Range, HeaderRow As Boolean)
Dim rsData As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
Dim r As Integer
If Range(sourceRange).Rows.Count = 1 Then
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
End If
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & "];"
On Error GoTo SomethingWrong
Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
TargetRange.Cells(1, 1).copyFromRecordset rsData
' Transpose the data
For r = 1 To 10
TargetRange.Cells(1, r) = TargetRange.Cells(r, 1)
Next r
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub
Display More
I'm wondering if the problem is caused by this line:
TargetRange.Cells(1, 1).copyFromRecordset rsData
which automatically copies the data across in its original form, but I reckon this line is very important(!) and I don't know if there is an alternative syntax.