與我的上一篇文章在這里，我想擴展它以使其檔案夾路徑不是硬編碼的。我想讓它讓用戶可以選擇要使用的檔案夾。我找到了這個帖子。我已將它添加到我的代碼（各種）中，它確實將我帶到檔案夾選擇對話框，我可以選擇一個檔案夾。但是，即使那里有檔案，它也無法讀取“找到 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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qianduan/390962.html
下一篇：vba計數問題