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

[russelldt]

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

 

[John_w]

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.

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

 

[russelldt]

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.

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]

Yes, assign the macro to the button. Or test it by running the macro from the Excel UI or the VBA editor.

 

[russelldt]

Good, thanks for the help John.

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

 

[russelldt]

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]

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.

#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]

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.

#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]

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]

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]

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,



Any help would be appreciated,

Thanks