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

Question

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 query: 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

Put your file names in an array and loop through that. What is the error - do you mean the workbook is not opened at all? — SJR, Jun 03 '20 at 18:07
No, When there is a difference in the name of the workbook or neither workbook exist the code stops there and go to the error handler. instead, if an error occurs then it has to resume and start opening next workbook and so on. if my explanation is not good please give me a chance to explain. — Srikanth Sare, Jun 03 '20 at 18:12
Try adapting this https://stackoverflow.com/questions/53528513/vba-error-handling-when-trying-to-open-workbook — SJR, Jun 03 '20 at 18:15
I have followed the steps but unable to do...Please Help !!! — Srikanth Sare, Jun 04 '20 at 11:03
For a loop I think you'll have to switch from sheet code names e.g. `Sheet12` to normal names. Do the normal names follow the code names? — SJR, Jun 06 '20 at 10:57

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

0 Answers0