Copy Specific Sheet of multiple workbook to multiple sheets of another workbook

[srikanth sare]

The below VBA code breaks if the name of the workbook or there is no workbook exist.

In my case, the VBA code breaks on opening workbook wbR4 due to difference in name and the code stops there itself and not proceeds to next workbook.

The code is about to copy specific sheet of source workbook and paste as values in target workbook in different sheets starts from sheet4.

MY QUERRY: Error handler has to show the name of the workbook where the error has occurred on opening. And the code has to resume and start copy from next workbook

And The below code can be simplified by the loop method, I have tried but due to lesser knowledge in VBA I'm unable to do so. Please help me.

Sub SRR()
On Error GoTo EH
    With Application
        .screenupdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With

    Dim wbR1, wbR2, wbR3, wbR4, wbR5, wbR6, wbR7, wbR8, wbR9, wbR10, wbR11 As Workbook
    Dim SA As Variant: SA = Sheet2.Range("F1").Value
    Dim SB As Variant: SB = Sheet2.Range("G1").Value
    Dim SC As Variant: SC = Sheet2.Range("H1").Value
    Dim SD As Variant: SD = Sheet2.Range("I1").Value
    Dim SE As Variant: SE = Sheet2.Range("J1").Value
    Dim SF As Variant: SF = Sheet2.Range("K1").Value
    Dim SG As Variant: SG = Sheet2.Range("L1").Value
    Dim SH As Variant: SH = Sheet2.Range("M1").Value
    Dim SI As Variant: SI = Sheet2.Range("N1").Value
    Dim SJ As Variant: SJ = Sheet2.Range("O1").Value
    Dim SK As Variant: SK = Sheet2.Range("P1").Value

    If IsEmpty(SA) = False Then
    Set wbR1 = Workbooks.Open(ThisWorkbook.Path & "\" & SA & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR1.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet4.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR1.Close SaveChanges = False
    End If

    If IsEmpty(SB) = False Then
    Set wbR2 = Workbooks.Open(ThisWorkbook.Path & "\" & SB & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR2.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet5.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR2.Close SaveChanges = False
    End If

    If IsEmpty(SC) = False Then
    Set wbR3 = Workbooks.Open(ThisWorkbook.Path & "\" & SC & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR3.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet6.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR3.Close SaveChanges = False
    End If

    If IsEmpty(SD) = False Then
    Set wbR4 = Workbooks.Open(ThisWorkbook.Path & "\" & SD & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR4.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet7.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR4.Close SaveChanges = False
    End If

    If IsEmpty(SE) = False Then
    Set wbR5 = Workbooks.Open(ThisWorkbook.Path & "\" & SE & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR5.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet8.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR5.Close SaveChanges = False
    End If

    If IsEmpty(SF) = False Then
    Set wbR6 = Workbooks.Open(ThisWorkbook.Path & "\" & SF & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR6.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet9.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR6.Close SaveChanges = False
    End If

    If IsEmpty(SG) = False Then
    Set wbR7 = Workbooks.Open(ThisWorkbook.Path & "\" & SG & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR7.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet10.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR7.Close SaveChanges = False
    End If

    If IsEmpty(SH) = False Then
    Set wbR8 = Workbooks.Open(ThisWorkbook.Path & "\" & SH & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR8.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet11.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR8.Close SaveChanges = False
    End If

    If IsEmpty(SI) = False Then
    Set wbR9 = Workbooks.Open(ThisWorkbook.Path & "\" & SI & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR9.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet12.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR9.Close SaveChanges = False
    End If

    If IsEmpty(SJ) = False Then
    Set wbR10 = Workbooks.Open(ThisWorkbook.Path & "\" & SJ & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR10.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet13.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR10.Close SaveChanges = False
    End If

    If IsEmpty(SK) = False Then
    Set wbR11 = Workbooks.Open(ThisWorkbook.Path & "\" & SK & ".xlsb", Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
    wbR11.Sheets(3).Range("A1:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy
    Sheet14.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    wbR11.Close SaveChanges = False
    End If

CleanUp:
    On Error Resume Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With
 Exit Sub
EH:
    Debug.Print Err. Description  ' Do error handling
        MsgBox "Sorry, an error occured." & vbCrLf & Err.Description, vbCritical, "Error!"
    Resume CleanUp
End Sub

 

[DanteAmor]

Assuming you want to copy sheet3 of book wbR1 to sheet4 of thisworkbook, sheet3 of book wbR2 on sheet5 of thisworkbook and so on.
I also assume sheet4 is in position number 4 in thisworkbook from left to right and sheet5 is in position number 5 and so on.

Try this

Sub SRR()
  Dim wbR1 As Workbook, fName As String, cop1 As String, cop2 As String
  Dim c As Range, n As Long, lr As Long
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
  End With
  
  n = 4
  For Each c In Sheet2.Range("F1:P1")
    If c.Value <> "" Then
      fName = ThisWorkbook.Path & "\" & c.Value & ".xlsb"
      If Dir(fName) <> "" Then
        Set wbR1 = Workbooks.Open(fName, Password:="Ssca@1818", WriteResPassword:="Ssca@1818", UpdateLinks:=0)
        lr = wbR1.Sheets(3).Range("A:N").Find("*", , xlValues, , xlByRows, xlPrevious).Row
        wbR1.Sheets(3).Range("A1:N" & lr).Copy
        ThisWorkbook.Sheets(n).Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        n = n + 1
        wbR1.Close False
        cop1 = cop1 & c.Value & vbCr
      Else
        cop2 = cop2 & c.Value & vbCr
      End If
    End If
  Next
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .CutCopyMode = False
  End With
  MsgBox "Copied Books" & vbCr & cop1 & vbCr & "These books do not exist" & vbCr & cop2
End Sub

 

[srikanth sare]

Thank You Dante Amor!!!
The VBA Code Has cleared all the queries.
This was the exact solution which I was looking for.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.