VBA单元值作为从文件夹中选择文件的日期范围

Question

我希望你能帮助我目前有一段代码（见下文）允许用户选择一个文件夹。然后，代码打开了所有工作簿该文件夹中，选择特定的表，从每个工作簿簿的副本时，该表中的数据名为“SearchCaseResults”表，然后将其粘贴到另一个文件夹中的另一个工作簿中的另一张“争议” 。

这一切都完美，但我现在想要发生的是，而不是打开文件夹中的每个工作簿。我只希望它能在基于B6和B7的单元格值的文件夹中打开Workbooks，我已将其制作为Date Picker，请参阅Pic 1以获得更好的理解。

因此，不是一块的代码状态，而文件夹做的不是空白

Do While myFile <> "" 

我想它说类似

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

上面的代码编译，但不不幸的工作

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

我已经用尽了在线资源并且已经搜索了几天的答案，因此我正在寻求帮助。

与往常一样，所有的帮助都非常感谢。

图片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 

PIC文件

Answer 1

如果您正在寻找B6和B7之间的日期最后修改的文件，然后交换到您当前的循环：

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 

但是，如果你想在文件名本身比较单元格中的日期，你将需要向我们展示了文件名的形式为我们提供帮助。