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

srikanth sare

New Member
Joined
May 1, 2020
Messages
10
Office Version
  1. 2013
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
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.
VBA Code:
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
 

Some videos you may like

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
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

VBA Code:
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

New Member
Joined
May 1, 2020
Messages
10
Office Version
  1. 2013
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
Thank You Dante Amor!!!
The VBA Code Has cleared all the queries.
This was the exact solution which I was looking for.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,311
Messages
5,600,886
Members
414,414
Latest member
neil_c

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top