与我的上一篇文章在这里，我想扩展它以使其档案夹路径不是硬编码的。我想让它让用户可以选择要使用的档案夹。我找到了这个帖子。我已将它添加到我的代码（各种）中，它确实将我带到档案夹选择对话框，我可以选择一个档案夹。但是，即使那里有档案，它也无法读取“找到 0 个 .csv 档案”中的档案。当档案路径被硬编码时，它将读取档案。这是我现在的代码（是的，它可能很糟糕，我完全不知道如何编码所以我只是复制/粘贴并更改我认为需要的内容并在开始时抛出此代码）

Function ChooseFolder() As String
Dim fldr As FileDialog
Dim sItem As String

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = "C:\Users\Me\Desktop\Extracted Data\"
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
ChooseFolder = sItem
Set fldr = Nothing
End Function
Sub MergeAllWorkbooksFinal()

Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, wsCSV As Worksheet
Dim rngCSV As Range, fnd As Range, bFound As Boolean
Dim Filename As String, n As Long, i As Long
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
      ' Refers to Function
Set objFolder = objFSO.GetFolder(ChooseFolder)

' Set summarysheet to activeworkbook/activesheet where the macro runs
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

' regular expression to extract numbers
' example VS SAAV_282579 ch 4 Data.csv
Dim Regex As Object, m As Object, SN As Long, CH As Long
Set Regex = CreateObject("vbscript.regexp")
With Regex
   .IgnoreCase = True
   .Pattern = "(_(\d ).* ch *(\d )  Data)"
End With

' Call Dir the first time, pointing it to all Excel files in the folder path.
Filename = Dir(objFolder & "*Data.csv*")

' Loop until Dir returns an empty string.
Application.ScreenUpdating = False
Do While Filename <> ""
    
    ' extract SN and Ch from filename
    If Regex.test(Filename) Then
        Set m = Regex.Execute(Filename)(0).submatches
        SN = m(1)
        CH = m(2)
        Debug.Print Filename, SN, CH
        
        ' Find SN
        Set fnd = ws.Range("B:B").Find(SN, LookIn:=xlValues, lookat:=xlWhole)
        If fnd Is Nothing Then
             MsgBox SN & " not found !", vbCritical, Filename
        Else
           ' find ch.
           bFound = False
           For i = 0 To fnd.MergeArea.Count - 1
                If ws.Cells(fnd.Row   i, "D") = CH Then ' Col D
                    bFound = True
                    ' Open a workbook in the folder
                    Set wbCSV = Workbooks.Open(objFolder & Filename, ReadOnly:=True)
                    ws.Cells(fnd.Row   i, "F").Resize(, 2).Value2 = wbCSV.Sheets(1).Range("B2:C2").Value2
                     ' Close the source workbook without saving changes.
                    wbCSV.Close savechanges:=False
                    Exit For
                End If
            Next
            If bFound = False Then
                MsgBox "Ch." & CH & " not found for " & SN, vbExclamation, Filename
            End If
        End If
        n = n   1
    Else
        Debug.Print Filename & " skipped"
    End If
    ' Use Dir to get the next file name.
    Filename = Dir()
Loop
    
' Call AutoFit on the destination sheet so that all
' data is readable.
ws.Columns.AutoFit
Application.ScreenUpdating = True

'Message Box when tasks are completed
MsgBox n & " csv files found.", vbInformation, "Task Complete!"

End Sub

对于原始代码，它是这样的：

Sub MergeAllWorkbooksFinal()

' Modify this folder path to point to the files you want to use. *add a '\' to end of the file name*
Const FolderPath = "C:\Users\Me\Desktop\Extracted Data\"

Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, wsCSV As Worksheet
Dim rngCSV As Range, fnd As Range, bFound As Boolean
Dim Filename As String, n As Long, i As Long
   
' Set summarysheet to activeworkbook/activesheet where the macro runs
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

' regular expression to extract numbers
' example VS SAAV_282579 ch 4 Data.csv
Dim Regex As Object, m As Object, SN As Long, CH As Long
Set Regex = CreateObject("vbscript.regexp")
With Regex
   .IgnoreCase = True
   .Pattern = "(_(\d ).* ch *(\d )  Data)"
End With

' Call Dir the first time, pointing it to all Excel files in the folder path.
Filename = Dir(FolderPath & "*Data.csv*")

' Loop until Dir returns an empty string.
Application.ScreenUpdating = False
Do While Filename <> ""
    
    ' extract SN and Ch from filename
    If Regex.test(Filename) Then
        Set m = Regex.Execute(Filename)(0).submatches
        SN = m(1)
        CH = m(2)
        Debug.Print Filename, SN, CH
        
        ' Find SN
        Set fnd = ws.Range("B:B").Find(SN, LookIn:=xlValues, lookat:=xlWhole)
        If fnd Is Nothing Then
             MsgBox SN & " not found !", vbCritical, Filename
        Else
           ' find ch.
           bFound = False
           For i = 0 To fnd.MergeArea.Count - 1
                If ws.Cells(fnd.Row   i, "D") = CH Then ' Col D
                    bFound = True
                    ' Open a workbook in the folder
                    Set wbCSV = Workbooks.Open(FolderPath & Filename, ReadOnly:=True)
                    ws.Cells(fnd.Row   i, "F").Resize(, 2).Value2 = wbCSV.Sheets(1).Range("B2:C2").Value2
                     ' Close the source workbook without saving changes.
                    wbCSV.Close savechanges:=False
                    Exit For
                End If
            Next
            If bFound = False Then
                MsgBox "Ch." & CH & " not found for " & SN, vbExclamation, Filename
            End If
        End If
        n = n   1
    Else
        Debug.Print Filename & " skipped"
    End If
    ' Use Dir to get the next file name.
    Filename = Dir()
Loop
    
' Call AutoFit on the destination sheet so that all
' data is readable.
ws.Columns.AutoFit
Application.ScreenUpdating = True

'Message Box when tasks are completed
MsgBox n & " csv files found.", vbInformation, "Task Complete!"

End Sub

TL：DR：需要让我的原始代码具有“选择档案夹”功能，该功能仍然可以读取所选档案夹中的资料/档案

编辑：如果有人感兴趣，这是我的最终代码：

Function PickFolder( _
Optional ByVal InitialFolderPath As String = "", _
Optional ByVal DialogTitle As String = "Browse", _
Optional ByVal DialogButtonName As String = "OK") _
As String
With Application.FileDialog(4) ' 4 = msoFileDialogFolderPicker
    .Title = DialogTitle
    .ButtonName = DialogButtonName
    Dim FolderPath As String
    If Len(InitialFolderPath) > 0 Then
        ' Note that the following block is NOT redundant.
        If Right(InitialFolderPath, 1) = "\" Then
            FolderPath = InitialFolderPath
        Else
            FolderPath = InitialFolderPath & "\"
        End If
        .InitialFileName = FolderPath
    End If
    If .Show Then
        FolderPath = .SelectedItems(1)
        If Right(FolderPath, 1) <> "\" Then
            FolderPath = FolderPath & "\"
        End If
        PickFolder = FolderPath
    Else
        ' Optionally, out-comment or use a message box.
        Debug.Print "'PickFolder': dialog canceled."
    End If
End With
End Function

Sub PickFolderTEST()
Const InitialFolderPath As String = "C:\Users\Me\Desktop\Extracted Data"
Dim FolderPath As String: FolderPath = PickFolder(InitialFolderPath)
If Len(FolderPath) = 0 Then Exit Sub

'Insert Cells
Range("E:G").EntireColumn.Insert
'Copy then paste cells
Range("H:J").Copy Range("E:F")
'Clear Contents
Range("F3:G1000").ClearContents

Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, wsCSV As Worksheet
Dim rngCSV As Range, fnd As Range, bFound As Boolean
Dim Filename As String, n As Long, i As Long
   
' Set summarysheet to activeworkbook/activesheet where the macro runs
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

' regular expression to extract numbers
' example VS SAAV_282579 ch 4 Data.csv
Dim Regex As Object, m As Object, SN As Long, CH As Long
Set Regex = CreateObject("vbscript.regexp")
With Regex
   .IgnoreCase = True
   .Pattern = "(_(\d ).* ch *(\d )  Data)"
End With

' Call Dir the first time, pointing it to all Excel files in the folder path.
Filename = Dir(FolderPath & "*Data.csv*")

' Loop until Dir returns an empty string.
Application.ScreenUpdating = False
Do While Filename <> ""
    
    ' extract SN and Ch from filename
    If Regex.test(Filename) Then
        Set m = Regex.Execute(Filename)(0).submatches
        SN = m(1)
        CH = m(2)
        Debug.Print Filename, SN, CH
        
        ' Find SN
        Set fnd = ws.Range("B:B").Find(SN, LookIn:=xlValues, lookat:=xlWhole)
        If fnd Is Nothing Then
             MsgBox SN & " not found !", vbCritical, Filename
        Else
           ' find ch.
           bFound = False
           For i = 0 To fnd.MergeArea.Count - 1
                If ws.Cells(fnd.Row   i, "D") = CH Then ' Col D
                    bFound = True
                    ' Open a workbook in the folder
                    Set wbCSV = Workbooks.Open(FolderPath & Filename, ReadOnly:=True)
                    ws.Cells(fnd.Row   i, "F").Resize(, 2).Value2 = wbCSV.Sheets(1).Range("B2:C2").Value2
                     ' Close the source workbook without saving changes.
                    wbCSV.Close savechanges:=False
                    Exit For
                End If
            Next
            If bFound = False Then
                MsgBox "Ch." & CH & " not found for " & SN, vbExclamation, Filename
            End If
        End If
        n = n   1
    Else
        Debug.Print Filename & " skipped"
    End If
    ' Use Dir to get the next file name.
    Filename = Dir()
Loop
    
' Call AutoFit on the destination sheet so that all
' data is readable.
ws.Columns.AutoFit
Application.ScreenUpdating = True

'Message Box when tasks are completed
MsgBox n & " csv files found.", vbInformation, "Task Complete!"

End Sub

uj5u.com热心网友回复：

选择一个档案夹

• 在您的代码中，您可以使用这样的PickFolder函式：

Sub PickFolderTEST()
    Const InitialFolderPath As String = "C:\Users\Me\Desktop\Extracted Data"
    Dim FolderPath As String: FolderPath = PickFolder(InitialFolderPath)
    If Len(FolderPath) = 0 Then Exit Sub
    
    ' Continue with the code...
    MsgBox "You picked the folder '" & FolderPath & "'.", vbInformation
    
End Sub

功能

Function PickFolder( _
    Optional ByVal InitialFolderPath As String = "", _
    Optional ByVal DialogTitle As String = "Browse", _
    Optional ByVal DialogButtonName As String = "OK") _
As String
    With Application.FileDialog(4) ' 4 = msoFileDialogFolderPicker
        .Title = DialogTitle
        .ButtonName = DialogButtonName
        Dim FolderPath As String
        If Len(InitialFolderPath) > 0 Then
            ' Note that the following block is NOT redundant.
            If Right(InitialFolderPath, 1) = "\" Then
                FolderPath = InitialFolderPath
            Else
                FolderPath = InitialFolderPath & "\"
            End If
            .InitialFileName = FolderPath
        End If
        If .Show Then
            FolderPath = .SelectedItems(1)
            If Right(FolderPath, 1) <> "\" Then
                FolderPath = FolderPath & "\"
            End If
            PickFolder = FolderPath
        Else
            ' Optionally, out-comment or use a message box.
            Debug.Print "'PickFolder': dialog canceled."
        End If
    End With
End Function