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?
' 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
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
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.