PDA

View Full Version : Using ADO Connection to Copy Data From Multiple Workbooks Help



BenChod
06-12-2017, 07:02 AM
Hi All -

I am using an ADO connection to copy data from multiple workbooks in to a separate summary workbook. There are a total of five workbooks in a folder (source). There are four workbook (each name is different) that I want to combine the data into one sheet called 'Summary' in my destination workbook. The fifth workbook, I want to copy the data into a different sheet called 'QC' in the same destination workbook. There is an array that keeps the inventory of all the files in the source folder. I made a couple of changes in the code to copy the data to the correct sheets and it's not working properly. Hoping someone can take a quick look to see what I am doing wrong.


Sub GetSheetsDir()
Dim MyPath As String
Dim FilesInPath As String
Dim sh As Worksheet, sh1 As Worksheet
Dim MyFiles() As String
Dim Fnum As Long, Fnum1 As Long
Dim rnum As Long, rnum1 As Long
Dim destrange As Range, destrange1 As Range
MyPath = "C:\LindaReports" ' <<<< 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 = "Summary" '& Format(Now, "mm-dd-yy")

Set sh1 = ActiveWorkbook.Worksheets.Add
sh1.Name = "QC"
'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)
rnum1 = LastRow(sh1)
'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "B")
Set destrange1 = sh1.Cells(rnum1 + 1, "A")
' Copy the workbook name in Column E
sh.Cells(rnum + 1, "A").Value = Left(MyFiles(Fnum), InStrRev(MyFiles(Fnum), ".") - 1)
' sh.Cells(rnum + 1, "A").Value = MyFiles(Fnum)
'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData MyPath & MyFiles(Fnum), "Summary", "A1:J500", destrange, False, False
GetData MyPath & MyFiles("QC"), "Sheet1", "A1:AD5000", destrange1, False, False
' sh.Range("A" & Lastrow(sh)).Value = MyFiles(Fnum)
Next
End If
'Range("A:A").Replace What:=".xls*", Replacement:="", Lookat:=xlPart
CleanUp:
Application.ScreenUpdating = True
End Sub

Jan Karel Pieterse
06-13-2017, 07:41 AM
Isn't the GetData routine the one we'd need to trouble-shoot this?

BenChod
06-13-2017, 10:25 AM
The more I think about, I don't think it is possible to select a specific file form a group of files to copy and paste from using ADO connection. Maybe someone can confirm.

JKwan
06-13-2017, 12:22 PM
yes you can, you use :
Select * From [Sheet1$]

BenChod
06-13-2017, 01:35 PM
Sorry, I meant with the current code I am using. The code I posted will take all the files in the directory and copy the data range from the first sheet from each file and paste that data range into another worksheet in another workbook. With the current set up, I don't think there is a way to copy the data from the first sheet from files X, Y, Z and paste and for file A copy and paste to another sheet.

JKwan
06-13-2017, 02:03 PM
OK, misunderstood.
You can still do it. You need to do a conditional check, I am throwing mud


select case MyFiles(Fnum)
case "fileA"
do your SQLA
do your copy to workbookA

case "fileB
do your SQLB
do your copy to workbookB
end select

BenChod
06-14-2017, 05:42 AM
Thanks for all your help. I found a simple solution. I am going to the keep one of the files in a different folder and call it from there.