VBA：打开文件夹中的所有文件

Question

我试图打开文件夹中的所有文件，然后从文件中复制数据并将它们添加到单个工作表中，关闭文件，然后将它们移到新文件夹中。 我是 VBA 的新手，这是我目前所拥有的：打开对话框并选择文件夹，打开工作簿，然后关闭工作簿。 但是，当代码继续打开工作簿时，我的 excel 出现故障并被冻结。 请帮忙。

Sub OpenFilesinFolderModWorkingDoc()

'create reference workbook variables


Dim FolderPath As String    'path of folder
Dim CPath As String 'path for current workbooks
Dim CName As String 'name for current workbooks
Dim DiaFolder As FileDialog
Dim mwb As Workbook 'individual workbooks


'Turn off settings
Application.ScreenUpdating = False

'File Dialogue
 Set DiaFolder = Application.FileDialog(msoFileDialogFolderPicker)
 DiaFolder.AllowMultiSelect = False
 DiaFolder.Show
 FolderPath = DiaFolder.SelectedItems(1)

CPath = FolderPath & "\" ' location of files
CName = Dir(CPath & "*.xlsx")

'loop through files in folder

Do While CName <> "" 'Loop through all files in selected folder
Set mwb = Workbooks.Open(CPath & "\" & CName)
mwb.Close True
Loop
End Sub

Answer 1

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

-抢

Answer 2

我实际上在我的机器上尝试了你的确切代码，它碰巧出现了故障，这让我感到惊讶，因为代码看起来不错。 我放慢了速度，我认为这可能是因为文件存储在 oneDrive（MS 云）上而不是保存在我的本地硬盘上。

我的问题是它一直试图立即保存，这是在一个驱动器上实时保存时的行为。

尝试在本地目录（可能是下载内容）或任何未与 Microsoft OneDrive 同步的文件夹中进行测试。

Answer 3

循环遍历选定文件夹 ( 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