只是一些思考的食物，我在过去做过类似的事情，但它是与Excel中的Power Query（数据-查询和连接），不确定这是否是一个选项，为您或没有。它可以将多个文件合并成一个，然后使用Power Automate您可以将文件移动到另一个目录。

• 罗伯

我实际上在我的机器上尝试了你的确切代码，它发生了故障，也让我感到惊讶，因为代码看起来不错。我放慢了速度，我认为这可能是由于文件被存储在OneDrive（MS云）上，而不是将其保存在我的本地硬盘上。
我的问题是，它一直试图立即保存，这是行为时，在一个驱动器，因为它保存在真实的。
尝试在下载中的本地目录或未与Microsoft OneDrive同步的任何文件夹上进行测试。

遍历选定文件夹（FileDialog）的文件（Dir）

Sub ImportDataFromMod()
    
    ' Define constants.
    
    Const PROC_TITLE As String = "Import Data From Mod"
    Const SRC_FILE_PATTERN As String = "*.xlsx"
    
    ' Select the Source folder.
    
    Dim pSep As String: pSep = Application.PathSeparator
    
    Dim fodg As FileDialog
    Set fodg = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim sFolderPath As String
    
    If fodg.Show Then ' OK
        sFolderPath = fodg.SelectedItems(1)
    Else ' Cancel
        MsgBox "No folder selected.", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    If Right(sFolderPath, 1) <> pSep Then sFolderPath = sFolderPath & pSep
    
    ' Get the first file name.
    
    Dim sFileName As String: sFileName = Dir(sFolderPath & SRC_FILE_PATTERN)
    
    If Len(sFileName) = 0 Then
        MsgBox "No files found in '" & sFolderPath & "'.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
'    ' Reference the Destination objects (Copy Data Example).
'
'    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
'    Dim dws As Worksheet: Set dws = dwb.Sheets("Sheet1")
'    Dim dfCell As Range
'    Set dfCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    
    ' Copy the data...
    
    ' Turn off settings.
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
'    ' Continue (Copy Data Example).
'    Dim sws As Worksheet
'    Dim srg As Range
    
    Do While Len(sFileName) > 0
        Set swb = Workbooks.Open(sFolderPath & sFileName)
        
        ' Print the file names in the Immediate window (Ctrl+G).
        Debug.Print swb.Name
        
'        ' Continue (Copy Data Example).
'        Set sws = swb.Sheets("Sheet1")
'        With sws.UsedRange
'            Set srg = .Resize(.Rows.Count - 1).Offset(1) ' exclude headers
'        End With
'        srg.Copy dfCell ' copy
'        Set dfCell = dfCell.Offset(srg.Rows.Count) ' next destination cell
        
        swb.Close SaveChanges:=False ' don't save, they are just read from
        sFileName = Dir ' next file
    Loop

    ' Turn on settings.
    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "Data imported.", vbInformation, PROC_TITLE

End Sub