VBA单元格值作为从文件夹中select文件的date范围

我希望你能帮助我目前有一段代码（见下文），允许用户select一个文件夹。 代码然后打开该文件夹中的所有工作簿，从每个工作簿书中select一个名为“SearchCaseResults”的特定工作表，复制该工作表中的数据，然后将其粘贴到其他工作簿中另一个文件夹中的另一个工作表“Disputes”中。

这一切都完美的作品，但我现在想要发生的是，而不是打开文件夹中的每个工作簿。 我只希望它打开基于B6和B7的单元格值的文件夹中的工作簿，我已经做成一个date选取器见图1更好的理解。

所以，而不是文件夹不是空白状态的代码段

Do While myFile <> "" 

我想说这样的话

 Do While myFile >= "B6" And myFile <= "B7" 

上面的代码编译，但不能遗憾地工作

我的代码是否可以修改为仅在单元格B6和B7中设置的date范围内打开工作簿

我已经用尽了在线资源，并有几天的search这个答案，所以我伸出援手

与往常一样，所有的帮助，不胜感激。

图1

我的代码

 Sub LoopAllExcelFilesInFolder() 'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 'SOURCE: www.TheSpreadsheetGuru.com Dim wb As Workbook Dim myPath As String Dim myFile As String Dim myExtension As String Dim FldrPicker As FileDialog Dim lRow As Long Dim ws2 As Worksheet Dim y As Workbook 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Retrieve Target Folder Path From User Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Looper\" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode myPath = .SelectedItems(1) & "\" End With 'In Case of Cancel NextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings 'Target File Extension (must include wildcard "*") myExtension = "*.xls*" 'Target Path with Ending Extention myFile = Dir(myPath & myExtension) Set y = ThisWorkbook Set ws2 = y.Sheets("Disputes") 'Loop through each Excel file in folder Do While myFile <> "" 'Set variable equal to opened workbook Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook With wb.Sheets("SearchCasesResults") lRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2) End With wb.Close SaveChanges:=True 'Get next file name myFile = Dir Loop 'Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 

文件夹的图片

Answer 1

如果您正在查找上次在B6和B7中修改date的文件，则将其交换到当前循环中：

 Do While myFile <> "" If Int(FileDateTime(myPath & myFile)) >= Range("B6").Value And _ Int(FileDateTime(myPath & myFile)) <= Range("B7").Value Then 'Set variable equal to opened workbook Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook With wb.Sheets("SearchCasesResults") lRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2) End With wb.Close SaveChanges:=True End If 'Get next file name myFile = Dir Loop 

但是，如果您想将文件名本身与单元格中的date进行比较，则需要向我们显示文件名的格式，以便我们提供帮助。