Import workbook using a predetermined directory and the name found in a cell-CodePudding

I currently import sheets of data into excel that I am exporting from CAD. This includes summaries, counts and other data. I would like to add to the code so that it will import a file from a predetermined directory C:\Jobs\packlist and using a number inside a cell ='PL CALC'!B1 (this will determine the file name). The idea being to remove the open dialog box and increase automation.

This is what I have found that works so far. It opens a selected file and copies it into the workbook after sheet 18.

'import excel data sheet

Sub import()

Dim fName As String, wb As Workbook

'where to look for the framecad excel file

ChDrive "C:"
ChDir "C:\Jobs\packlist"

fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
    For Each sh In wb.Sheets
            Sheets.Copy After:=ThisWorkbook.Sheets(18)
            Exit For
            Next
    wb.Close False      
    Worksheets("PL CALC").Activate

End Sub

CodePudding user response：

Import Sheets

Option Explicit

Sub ImportSheets()
    Const ProcTitle As String = "Import Sheets"

    Const sFolderPath As String = "C:\Jobs\packlist\"
    Const sfnAddress As String = "B1"
    Const sFileExtensionPattern As String = ".xls*"
    
    Const dwsName As String = "PL CALC"
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dwsName)
    
    Dim sFilePattern As String: sFilePattern = sFolderPath & "*" _
        & dws.Range(sfnAddress).Value & sFileExtensionPattern
    
    Dim sFileName As String: sFileName = Dir(sFilePattern)
    If Len(sFileName) = 0 Then
        MsgBox "No file found..." & vbLf & "'" & sFilePattern & "'", _
            vbCritical, ProcTitle
        Exit Sub
    End If

    Application.ScreenUpdating = False
    
    Dim swb As Workbook: Set swb = Workbooks.Open(sFolderPath & sFileName)
        
    Dim sh As Object
        
    For Each sh In swb.Sheets
        sh.Copy After:=dwb.Sheets(dwb.Sheets.Count)
    Next sh
    
    swb.Close SaveChanges:=False
    
    dws.Activate
    'dwb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Sheets imported.", vbInformation, ProcTitle
    
End Sub