VBA solution to copy sheets from one excel workbook and past them into my current open workbook

russelldt

Board Regular
Joined
Feb 27, 2021
Messages
74
Office Version
  1. 365
Platform
  1. MacOS
I hope someone can help me. Here is the scenario. When I open a new Job File, I need to add (or copy) 2 specific sheets (Work and Detail) to the new job file. These sheets are in the quote file (Quote Number). The options for the Quote and sheets are in dropdown menu’s, and I need to select from 2 dropdown menus to get the sheet (i.e Quote Number and Work, or Quote Number and Detail). My thinking is that there could be a macro button (shown on the attached screenshot) that is pressed once the Quote number and scope are selected. The same would apply for the Detail.

Both files reside in the same directory (Call it 2021, but in separate sub directories ( Quote subdirectory and Job subdirectory)

So, in short, I want to copy 2 sheets from a Quote file, and add them to a job file, without having to open the quote file and using the "move" option, and I am looking to a VBA solution for this. There is a thread that i have followed

VBA; Copy a whole work sheet from another workbook and have it paste into a sheet in current workbook​

and I have tried the solution that was posted:

OpenBook.Sheets("Details").UsedRange.Copy
ThisWorkbook.Worksheets("Copy of Detail").Range("A1").PasteSpecial xlPasteValues,

...without any success, as I am using 2 dropdown menus

Both files reside in the same directory (Call it 2021, but in separate sub directories ( Quote subdirectory and Job subdirectory)

I would appreciate some help






Thanks
 

Attachments

  • Screen Shot 2021-09-10 at 12.39.11.png
    Screen Shot 2021-09-10 at 12.39.11.png
    117.6 KB · Views: 9

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,086
That seems clearer, thanks. Put this macro in a module in your Job workbook (.xlsm file) in the "Job Sheets" folder, since it looks for the Quote workbook using this relative path:

ThisWorkbook.Path & "\..\..\A Quotations\Quote Sheets\"

which is up 2 folder levels and down to the "Quote Sheets" folder.

VBA Code:
Public Sub Add_Quote_Sheets_To_This_Job()

    Dim QuoteNumber As String, QuoteSheet1 As String, QuoteSheet2 As String
    Dim QuoteWorkbookFile As String, QuoteWorkbook As Workbook
    Dim currentSheet As Worksheet, QuoteSheet As Worksheet
  
    With ActiveSheet
        QuoteNumber = .Range("A3").Value
        QuoteSheet1 = .Range("C3").Value
        QuoteSheet2 = .Range("D3").Value
        Set currentSheet = ActiveSheet
    End With
  
    If QuoteNumber <> "" And QuoteSheet1 <> "" And QuoteSheet2 <> "" Then
        QuoteWorkbookFile = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(ThisWorkbook.Path & "\..\..\A Quotations\Quote Sheets\" & QuoteNumber & ".xlsm")
        If Dir(QuoteWorkbookFile) <> vbNullString Then
            Set QuoteWorkbook = Workbooks.Open(QuoteWorkbookFile)
            Set QuoteSheet = Get_Sheet(QuoteWorkbook, QuoteSheet1)
            If Not QuoteSheet Is Nothing Then QuoteSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            Set QuoteSheet = Get_Sheet(QuoteWorkbook, QuoteSheet2)
            If Not QuoteSheet Is Nothing Then QuoteSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            QuoteWorkbook.Close False
            currentSheet.Activate
        Else
            MsgBox "Quote workbook not found: " & vbCrLf & QuoteWorkbookFile, vbExclamation, "Add Quote Sheets To This Workbook"
        End If
    End If

End Sub

Private Function Get_Sheet(wb As Workbook, SheetName As String) As Worksheet
    Set Get_Sheet = Nothing
    On Error Resume Next
    Set Get_Sheet = wb.Worksheets(SheetName)
    On Error GoTo 0
End Function
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

russelldt

Board Regular
Joined
Feb 27, 2021
Messages
74
Office Version
  1. 365
Platform
  1. MacOS
That seems clearer, thanks. Put this macro in a module in your Job workbook (.xlsm file) in the "Job Sheets" folder, since it looks for the Quote workbook using this relative path:

ThisWorkbook.Path & "\..\..\A Quotations\Quote Sheets\"

which is up 2 folder levels and down to the "Quote Sheets" folder.

VBA Code:
Public Sub Add_Quote_Sheets_To_This_Job()

    Dim QuoteNumber As String, QuoteSheet1 As String, QuoteSheet2 As String
    Dim QuoteWorkbookFile As String, QuoteWorkbook As Workbook
    Dim currentSheet As Worksheet, QuoteSheet As Worksheet
 
    With ActiveSheet
        QuoteNumber = .Range("A3").Value
        QuoteSheet1 = .Range("C3").Value
        QuoteSheet2 = .Range("D3").Value
        Set currentSheet = ActiveSheet
    End With
 
    If QuoteNumber <> "" And QuoteSheet1 <> "" And QuoteSheet2 <> "" Then
        QuoteWorkbookFile = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(ThisWorkbook.Path & "\..\..\A Quotations\Quote Sheets\" & QuoteNumber & ".xlsm")
        If Dir(QuoteWorkbookFile) <> vbNullString Then
            Set QuoteWorkbook = Workbooks.Open(QuoteWorkbookFile)
            Set QuoteSheet = Get_Sheet(QuoteWorkbook, QuoteSheet1)
            If Not QuoteSheet Is Nothing Then QuoteSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            Set QuoteSheet = Get_Sheet(QuoteWorkbook, QuoteSheet2)
            If Not QuoteSheet Is Nothing Then QuoteSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            QuoteWorkbook.Close False
            currentSheet.Activate
        Else
            MsgBox "Quote workbook not found: " & vbCrLf & QuoteWorkbookFile, vbExclamation, "Add Quote Sheets To This Workbook"
        End If
    End If

End Sub

Private Function Get_Sheet(wb As Workbook, SheetName As String) As Worksheet
    Set Get_Sheet = Nothing
    On Error Resume Next
    Set Get_Sheet = wb.Worksheets(SheetName)
    On Error GoTo 0
End Function
Thanks, and do i add this to the command (GO) button as well?
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,086
Yes, assign the macro to the button. Or test it by running the macro from the Excel UI or the VBA editor.
 

russelldt

Board Regular
Joined
Feb 27, 2021
Messages
74
Office Version
  1. 365
Platform
  1. MacOS
Good, thanks for the help John.

I will give you feedback once i have finished setting up the workbooks,
 

russelldt

Board Regular
Joined
Feb 27, 2021
Messages
74
Office Version
  1. 365
Platform
  1. MacOS

ADVERTISEMENT

Hello john,

At last i have been able to try this Via, and i assigned the macro the the "button", This is the message i received. I'm not sure what's missing, as i have a full Windows 365 license. Have you encountered this before?

I am Rundung many VBA scripts on other workbooks, so this does seem strange.

License information for this component not found. You do not have an appropriate license to use this functionality in the design environment
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,086
License information for this component not found. You do not have an appropriate license to use this functionality in the design environment
I suspect that error is caused by CreateObject("Scripting.FileSystemObject").GetAbsolutePathName, which is calling the Microsoft Scripting Runtime library (C:\Windows\SysWOW64\scrrun.dll). That file may not be installed on your computer or you don't have permission to access it.

Try this macro which uses the GetFullPathName API instead.
VBA Code:
#If VBA7 Then
    Private Declare PtrSafe Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
#Else
    Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
#End If


Public Sub Add_Quote_Sheets_To_This_Job2()

    Dim QuoteNumber As String, QuoteSheet1 As String, QuoteSheet2 As String
    Dim QuoteWorkbookFile As String, QuoteWorkbook As Workbook
    Dim currentSheet As Worksheet, QuoteSheet As Worksheet
    
    With ActiveSheet
        QuoteNumber = .Range("A3").Value
        QuoteSheet1 = .Range("C3").Value
        QuoteSheet2 = .Range("D3").Value
        Set currentSheet = ActiveSheet
    End With
    
    If QuoteNumber <> "" And QuoteSheet1 <> "" And QuoteSheet2 <> "" Then
        QuoteWorkbookFile = GetAbsolutePath(ThisWorkbook.path & "\..\..\A Quotations\Quote Sheets\" & QuoteNumber & ".xlsm")
        If Dir(QuoteWorkbookFile) <> vbNullString Then
            Set QuoteWorkbook = Workbooks.Open(QuoteWorkbookFile)
            Set QuoteSheet = Get_Sheet(QuoteWorkbook, QuoteSheet1)
            If Not QuoteSheet Is Nothing Then QuoteSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            Set QuoteSheet = Get_Sheet(QuoteWorkbook, QuoteSheet2)
            If Not QuoteSheet Is Nothing Then QuoteSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            QuoteWorkbook.Close False
            currentSheet.Activate
        Else
            MsgBox "Quote workbook not found: " & vbCrLf & QuoteWorkbookFile, vbExclamation, "Add Quote Sheets To This Workbook"
        End If
    End If

End Sub


Private Function Get_Sheet(wb As Workbook, SheetName As String) As Worksheet
    Set Get_Sheet = Nothing
    On Error Resume Next
    Set Get_Sheet = wb.Worksheets(SheetName)
    On Error GoTo 0
End Function


Private Function GetAbsolutePath(path As String) As String
    Dim pathLen As Long
    GetAbsolutePath = Space(255)
    pathLen = GetFullPathName(path, Len(GetAbsolutePath), GetAbsolutePath, "")
    GetAbsolutePath = Left(GetAbsolutePath, pathLen)
End Function
 

russelldt

Board Regular
Joined
Feb 27, 2021
Messages
74
Office Version
  1. 365
Platform
  1. MacOS

ADVERTISEMENT

I suspect that error is caused by CreateObject("Scripting.FileSystemObject").GetAbsolutePathName, which is calling the Microsoft Scripting Runtime library (C:\Windows\SysWOW64\scrrun.dll). That file may not be installed on your computer or you don't have permission to access it.

Try this macro which uses the GetFullPathName API instead.
VBA Code:
#If VBA7 Then
    Private Declare PtrSafe Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
#Else
    Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
#End If


Public Sub Add_Quote_Sheets_To_This_Job2()

    Dim QuoteNumber As String, QuoteSheet1 As String, QuoteSheet2 As String
    Dim QuoteWorkbookFile As String, QuoteWorkbook As Workbook
    Dim currentSheet As Worksheet, QuoteSheet As Worksheet
   
    With ActiveSheet
        QuoteNumber = .Range("A3").Value
        QuoteSheet1 = .Range("C3").Value
        QuoteSheet2 = .Range("D3").Value
        Set currentSheet = ActiveSheet
    End With
   
    If QuoteNumber <> "" And QuoteSheet1 <> "" And QuoteSheet2 <> "" Then
        QuoteWorkbookFile = GetAbsolutePath(ThisWorkbook.path & "\..\..\A Quotations\Quote Sheets\" & QuoteNumber & ".xlsm")
        If Dir(QuoteWorkbookFile) <> vbNullString Then
            Set QuoteWorkbook = Workbooks.Open(QuoteWorkbookFile)
            Set QuoteSheet = Get_Sheet(QuoteWorkbook, QuoteSheet1)
            If Not QuoteSheet Is Nothing Then QuoteSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            Set QuoteSheet = Get_Sheet(QuoteWorkbook, QuoteSheet2)
            If Not QuoteSheet Is Nothing Then QuoteSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            QuoteWorkbook.Close False
            currentSheet.Activate
        Else
            MsgBox "Quote workbook not found: " & vbCrLf & QuoteWorkbookFile, vbExclamation, "Add Quote Sheets To This Workbook"
        End If
    End If

End Sub


Private Function Get_Sheet(wb As Workbook, SheetName As String) As Worksheet
    Set Get_Sheet = Nothing
    On Error Resume Next
    Set Get_Sheet = wb.Worksheets(SheetName)
    On Error GoTo 0
End Function


Private Function GetAbsolutePath(path As String) As String
    Dim pathLen As Long
    GetAbsolutePath = Space(255)
    pathLen = GetFullPathName(path, Len(GetAbsolutePath), GetAbsolutePath, "")
    GetAbsolutePath = Left(GetAbsolutePath, pathLen)
End Function
Thanks John. I think the Mac version of Excel is not as complete as the original MS version.
I will try this and let you know how it works.
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,086
I didn't know you were running it on a Mac - that would explain the license error.

I don't know how to modify the code to work on a Mac - the issue is the relative directory path "\..\.." in "\..\..\A Quotations\Quote Sheets\", which means up 2 folder levels in Windows (DOS). I don't know the equivalent on a Mac.

The only reason for using GetAbsolutePath or GetFullPathName in Windows is to resolve the relative path to the absolute path, for display purposes in the MsgBox so that the user sees the 2 actual folder names instead of "..\.." in the displayed string. The same thing could be done with a bit of string manipulation (e.g. Instr, Mid functions) on a Mac.
 

russelldt

Board Regular
Joined
Feb 27, 2021
Messages
74
Office Version
  1. 365
Platform
  1. MacOS
I didn't know you were running it on a Mac - that would explain the license error.

I don't know how to modify the code to work on a Mac - the issue is the relative directory path "\..\.." in "\..\..\A Quotations\Quote Sheets\", which means up 2 folder levels in Windows (DOS). I don't know the equivalent on a Mac.

The only reason for using GetAbsolutePath or GetFullPathName in Windows is to resolve the relative path to the absolute path, for display purposes in the MsgBox so that the user sees the 2 actual folder names instead of "..\.." in the displayed string. The same thing could be done with a bit of string manipulation (e.g. Instr, Mid functions) on a Mac.
John,

This is the message i get when i rum the macro.
 

russelldt

Board Regular
Joined
Feb 27, 2021
Messages
74
Office Version
  1. 365
Platform
  1. MacOS
John,

This is the message i get when i rum the macro.
Hello John, I have tried to run this, but i still can't figure out what's wrong. This is the message i get,

Screen Shot 2021-10-12 at 20.08.14.png

Any help would be appreciated,

Thanks
 

Forum statistics

Threads
1,147,962
Messages
5,744,060
Members
423,843
Latest member
alex2022

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