与我的上一篇文章在这里,我想扩展它以使其档案夹路径不是硬编码的。我想让它让用户可以选择要使用的档案夹。我找到了这个帖子。我已将它添加到我的代码(各种)中,它确实将我带到档案夹选择对话框,我可以选择一个档案夹。但是,即使那里有档案,它也无法读取“找到 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
0 评论