Loop Through Workbooks in A Folder and Copy / Paste to Another Workbook

[BenChod]

Hi -

I have several workbooks in a folder that I want to loop through. Each workbook have over 20 worksheets. The following code loops through each workbook, creates a worksheet and copies a specific value from each worksheet into the new worksheet. I then want to copy the data range from the new worksheet to the workbook where the code is executed and append the data to a specific worksheet in the workbook where the code is executed from. The problem I can't figure out is how to copy the data range from the other workbooks into the workbook that is executing the code.

Here is the code I am using. Right before the loop, I have the code where I want to copy the selected range to the target workbook and it's not working. I want to append the data so the copy and paste should happed at the end of the data range. Any help would be appreciated.


Public Sub test()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim i As Long
Dim NewSh As Worksheet
Dim sh As Worksheet
Dim LastRow1 As Long
Dim x As Range
Path = "C:\Data\"
Filename = Dir(Path & "*.xls*")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & Filename)

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the search Value
MyArr = Array("QC*")
'Add new worksheet to your workbook to copy to
'You can also use a existing sheet like this
' Set NewSh = Sheets("DL")
Set NewSh = Worksheets.Add
NewSh.Name = "DL"
' Cells(1, 1) = "EF"
For Each sh In ActiveWorkbook.Worksheets
Select Case "Summary"
Case Else


With sh.Cells.Range("A1:Z100")
' LastRow1 = Sheets("DL").Cells(sh.Rows.Count, "A").End(xlUp).Row

' .Range ("A1:Z100")
'Range("A1", Columns("A").SpecialCells(xlCellTypeLastCell)).Delete

' Cells(LastRow1 + 1, 1).Activate
Rcount = 0 + Rcount
For i = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(i), _
after:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1

' Rng.Copy NewSh.Range("A" & Rcount)
' NewSh.Range("B" & Rcount).Resize(Rng.Rows.Count).Value = sh.Name
' NewSh.Range(LastRow1).Activate
' Use this if you only want to copy the value
NewSh.Range("B" & Rcount).Value = Rng.Value
NewSh.Range("A" & Rcount).Resize(Rng.Rows.Count).Value = sh.Name
' NewSh.Cells(LastRow1 + 1, Rcount) = Rng.Value

Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next i
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Select
Next sh

Range("A1").CurrentRegion.Copy Destination:=Workbooks("DEV_BlockDefectReport.xlsx")

' MsgBox Filename & " has opened"
wbk.Close True
Filename = Dir
Rcount = 0

Loop
End Sub

[mdmackillop]

Set your destination at the start of the code before you open any other workbooks


Dim Tgt As Range
Set Tgt = ThisWorkbook.Sheet1.Cells(1, 1)

'Your code


Range("A1").CurrentRegion.Copy Tgt

BTW when working across multiple workbooks/sheets it is best to fully qualify ranges e.g. wb2.sheet2.Range("A1") in the code above.

[BenChod]

You are more impressive than William Wallace. Question, when copying, the data from the other worksheets are not being copied to the last row. I added these lines and still not working:

With ActiveSheet
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set Tgt = ThisWorkbook.Sheets("DL").Cells("A" & LastRow1)

[mdmackillop]

Set tgt = ThisWorkbook.Sheets("DL").Cells(Rows.Count, 1).End(xlUp)(2)

[BenChod]

Thank you. It wasn't working and then I realized that I that I need to put 'Set tgt = ThisWorkbook.Sheets("DL").Cells(Rows.Count, 1).End(xlUp)(2)' after the do while code line. Looks like it works. Thanks again.