Loop, copy data from different workbooks with cellvalues as pathway and sheetname

[Daniel_72]

Hi

I have a Masterfile. The Masterfile contains a lot of sheets.
I would like to loop through all sheets that are not excluded (as below) and open a different workbook and sheet for all of them, according to cell value in B1 (Pathway) and H1 (sheet name).

I then want to copy a range from each workbook and from correct sheet and paste it in the master to the correct sheet. After copy and paste I want to close the file that has been opened and
then go to next sheet in the loop. Some parts of the code are working but for some reason it fails to activate the correct sheet after the workbook is opened.

I would appreciate some help – what am I missing?

Here is the code that I have so far:

Sub Test()

Dim wb1 As Workbook

Dim wb2 As Workbook

Dim ws1 As Worksheet

Dim ws2 As Worksheet

Set wb1 = ThisWorkbook

Set wb2 = ActiveWorkbook

Set ws1 = ActiveSheet

Set ws2 = ActiveSheet

For Each ws1 In ActiveWorkbook.Worksheets

If ws1.Name = "Master" Then GoTo NextSheet

If ws1.Name = "Instruction" Then GoTo NextSheet

If ws1.Name = "Report" Then GoTo NextSheet

If ws1.Name <> ActiveSheet.Name Then

ws1.Select

With ws1

PathName = Range("B1").Value

ws2.Name = Range("H1").Value

Workbooks.Open Filename:=PathName

ws2.Activate

Range("B6:F13").Copy

Set wb2 = ActiveWorkbook

wb1.Activate

Range("B6:F13").PasteSpecial Paste:=xlPasteValues

wb2.Activate

wb2.Close SaveChanges:=True

End With

End If

NextSheet:

Next ws1

End Sub

 

[Herakles]

You don't need to activate the sheet that you are getting data from and writing data to, you just need
to reference them.

Use test data to test this.

Public Sub subLoopFetchData()
Dim Ws As Worksheet

    ActiveWorkbook.Save
        
    For Each Ws In ActiveWorkbook.Sheets
    
        ' Exclude certain worksheets.
        If InStr(1, "Master,Instructions,Report", Ws.Name, vbTextCompare) = 0 Then
              
            ' Check to see if the workbook exists.                      
            If Dir(Ws.Range("B1")) <> "" Then
            
                Workbooks.Open Ws.Range("B1")
                
                Ws.Range("B6:F13").Value = ActiveWorkbook.Sheets(Ws.Range("H1").Value).Range("B6:F13").Value
                
                ActiveWorkbook.Close
        
            End If
            
        End If
    
    Next Ws

End Sub

 

[Daniel_72]

Thanks a lot Herakles, that works perfect! I am very grateful for your help