excel - 选择文件夹路径 - 不读取所选文件夹中的文件

Question

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

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:博士:
需要使我的原始代码具有“选择文件夹”功能，仍然可以读取所选文件夹中的数据/文件
编辑:如果有人感兴趣，这是我的最终代码:

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

Answer 1

选择一个文件夹

在您的代码中，您可以使用 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