从关闭的工作簿导入数据

Sub ImportData()

    ' Define constants.
    
    Const PROC_TITLE As String = "Import Data"
    Const SRC_INITIAL_FOLDER_PATH As String = "C:\Importfiler test\"
    Const SRC_FILE_PATTERN As String = "*.xlsx"
    Const SRC_WORKSHEET_NAME As String = "Import Fil"
    Const SRC_FIRST_ROW As String = "A5:CZ5"
    Const DST_FOLDER_PATH As String = "C:\Importfiler test\"
    Const DST_WORKBOOK_NAME As String = "TOT_Importfiler.xlsm"
    Const DST_WORKSHEET_NAME As String = "Blad1"
    Const DST_FIRST_COLUMN As String = "A"

    Dim pSep As String: pSep = Application.PathSeparator
    
    ' Check if the Destination folder and file exist.

    ' Correct.
    Dim dPath As String: dPath = DST_FOLDER_PATH
    If Right(dPath, 1) <> pSep Then dPath = dPath & pSep
    ' Folder
    If Len(Dir(dPath, vbDirectory)) = 0 Then
        MsgBox "The Destination folder '" & dPath & "' doesn't exist.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
    ' File
    Dim dFilePath As String: dFilePath = dPath & DST_WORKBOOK_NAME
    If Len(Dir(dFilePath)) = 0 Then
        MsgBox "The Destination file '" & DST_WORKBOOK_NAME & "' was not " _
            & "found in '" & dPath & "'.", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Select the Source folder.
    
    Dim sPath As String: sPath = SRC_INITIAL_FOLDER_PATH
    If Right(sPath, 1) <> pSep Then sPath = sPath & pSep

    Dim FolderDialogCanceled As Boolean
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sPath
        If .Show Then
            sPath = .SelectedItems(1)
            If Right(sPath, 1) <> pSep Then sPath = sPath & pSep
        Else
            FolderDialogCanceled = True
        End If
    End With
            
    If FolderDialogCanceled Then
        MsgBox "No folder selected.", vbExclamation, PROC_TITLE
        Exit Sub
    End If

    ' Check if there are any files in the Source folder.
    
    Dim sFileName As String: sFileName = Dir(sPath & SRC_FILE_PATTERN)
    If Len(sFileName) = 0 Then
        MsgBox "No Source files found in '" & sPath & "'.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If

    ' Reference the Destination objects.
    
    Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
    
    Dim dws As Worksheet
    On Error Resume Next
        Set dws = dwb.Worksheets(DST_WORKSHEET_NAME)
    On Error GoTo 0
    If dws Is Nothing Then
        MsgBox "The worksheet '" & DST_WORKSHEET_NAME & "' was not found in " _
            & "the workbook '" & DST_WORKBOOK_NAME & "'.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
        
    Dim dfCell As Range
    With dws.UsedRange
        Set dfCell = dws.Cells(.Row + .Rows.Count, DST_FIRST_COLUMN)
    End With

    Dim cCount As Long: cCount = dws.Range(SRC_FIRST_ROW).Columns.Count

    ' Copy the data.
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range, slCell As Range
    Dim rCount As Long

    Do While Len(sFileName) > 0
        Set swb = Workbooks.Open(sPath & sFileName)
        On Error Resume Next
            Set sws = swb.Worksheets(SRC_WORKSHEET_NAME)
        On Error GoTo 0
        If Not sws Is Nothing Then ' worksheet exists
            If sws.FilterMode Then sws.ShowAllData
            With sws.Range(SRC_FIRST_ROW)
                ' Reference the Source range.
                Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
                    .Find("*", , xlFormulas, , , xlPrevious)
                If Not slCell Is Nothing Then ' data in worksheet found
                    rCount = slCell.Row - .Row + 1
                    Set srg = .Resize(rCount)
                    ' Copy values.
                    With dfCell.Resize(rCount)
                        .Value = sFileName
                        .Offset(, 1).Resize(, cCount).Value = srg.Value
                    End With
                    Set dfCell = dfCell.Offset(rCount)
                'Else ' no data in worksheet found; do nothing
                End If
            End With
            Set sws = Nothing ' reset for the next iteration
        'Else ' worksheet doesn't exist; do nothing
        End If
        swb.Close SaveChanges:=False ' it was just read from
        sFileName = Dir
    Loop

    Application.ScreenUpdating = True

    ' Inform.
    
    MsgBox "Data imported!", vbInformation, PROC_TITLE

End Sub

修改以下代码行

.Range("A5:CZ" & lRow).Copy
 ws2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues

要在上面一行之后使用以下代码添加文件名

ws2.Range("A" & Rows.Count).End(xlUp)(2).offset(0,104) = myFile