Excel VBA：通过多个variables查找，匹配和复制

我是VBA编码的初学者，请耐心等待。 现在的问题是，我需要创build一个“自动化”，易于使用的报告创buildexcel。

我已经尝试了不同的VLOOKUP，MATCH＆INDEXconfiguration等，没有任何东西似乎以我需要的方式工作。 我已经search并寻找解决scheme，但所有的答案似乎是如此具体的案件，他们只刷我的问题。

简而言之，我需要一个macros，可以从工作簿（位于特定的源文件夹中 ）查找，匹配和复制数据行（按date和产品编号 ）到新的工作表和/或工作簿，并将其保存为search条件（如“productno 1-1-2017_31-1-2017.xlsx”）

例如，我可以search1.1.2017到31.1.2017之间的“ProductABC”的所有条目，并将数据另存为新的单独报告文件。

产品和产品编号将被存储到报告创build工作簿的子工作表“产品列表”中。

源文件夹按年份sorting：“… \ Products \ Reports \ 2017.xlsx”报表数据正在显示如下：

ABCDE 1 Productno Product Attribute Date Time 2 123456 ProductABC 1,05 1.1.2017 10:30 3 654321 ProductCBA 1,10 1.1.2017 14:01 4 999999 ProductXYZ 1,15 3.1.2017 09:17 

报告创build工作表大致如下所示：

  AB 1 Create Report 2 Starting date: d/m/yyyy 3 End date: d/m/yyyy 4 Product: Dropdown list 5 Search product data button 6 Create report button 

在其他一些失败的实验中，我在网上find了这个代码片段，试图绕过它来适应我的需要。 我知道这不是完整的，甚至可能不是我所需要的，但是就我所知，

 Private Sub CommandButton3_Click() With Application .ScreenUpdating = False .EnableEvents = False End With Dim Source As Workbook Dim Target As Workbook Dim NewSh As Worksheet '## Open both workbooks first: Set Source = Workbooks.Open(ThisWorkbook.Path & "\2016") Set Target = Workbooks.Open(ThisWorkbook.Path & "\New_report") Set NewSh = Worksheets.Add Dim FindString As String Dim Rng As Range Workbooks("Create_report").Activate FindString = Sheets("Functions").Range("C2").Value If Trim(FindString) <> "" Then Workbooks("2016").Activate With Sheets("Sheet1").Range("A:A") Set Rng = .Find(What:=FindString, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng Is Nothing Then Application.Goto Rng, True Rng.Copy Target.Range("A" & Rcount) Else MsgBox "No products found!" End If End With End If 'Save Target worksheet changes: Target.SaveAs (ThisWorkbook.Path & "\New report 1") 'Close workbooks Source.Close Target.Close With Application .ScreenUpdating = True .EnableEvents = True End With End Sub 

！ 更新！

我已经取得了一些进展，我的代码，这是最新版本：

 Sub Etsiva_click() 'Optimazation With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With 'Dimensions and definitions 'Source folder etc. Dim FolderPath As String, FileName As String FolderPath = "C:\Users\MYUSERNAME\Documents\Projects\Excel\Tests\Data\" FileName = Dir(FolderPath & "*.xl*") 'Workbooks and sheets Dim WorkBk As Workbook Dim wbok1 As Workbook Set wbok1 = ThisWorkbook Dim WSS As Sheets Set WSS = wbok1.Worksheets Dim DemPest As Worksheet Set DemPest = WSS("Temp") Dim ACtion As Worksheet Set ACtion = WSS("Functions") Dim nRows As Long, LastRow As Long Dim CurYear As Date, StartDate As Date, EndDate As Date Dim ProDuct As String 'Count last row for product and date columns LastRow = Cells(Rows.Count, 1).End(xlUp).Row And Cells(Rows.Count, 4).End(xlUp).Row 'Starting row nRows = 3 'Search variables StartDate = ACtion.Range("A2").Value EndDate = ACtion.Range("A3").Value ProDuct = ACtion.Range("A4").Value 'Empty "Temp" sheet before pasting new data DemPest.Range("2:7").ClearContents 'THE Code 'Loop folder/files Do While FileName <> "" 'Open a workbook in the folder Set WorkBk = Workbooks.Open(FolderPath & FileName) 'Inner loop (below) does the copy/pasting Do If WorkBk.Worksheets("Sheet1").Cells(nRows, 4).Value < EndDate And WorkBk.Worksheets("Sheet1").Cells(nRows, 4) > StartDate And WorkBk.Worksheets("Sheet1").Cells(nRows, 1) = ProDuct Then DemPest.Cells(nRows, 1).Value = WorkBk.Worksheets("Sheet1").Cells(nRows, 1).Value 'Product number DemPest.Cells(nRows, 2).Value = WorkBk.Worksheets("Sheet1").Cells(nRows, 2).Value 'Product DemPest.Cells(nRows, 3).Value = WorkBk.Worksheets("Sheet1").Cells(nRows, 3).Value 'Data DemPest.Cells(nRows, 4).Value = WorkBk.Worksheets("Sheet1").Cells(nRows, 4).Value 'Date DemPest.Cells(nRows, 5).Value = WorkBk.Worksheets("Sheet1").Cells(nRows, 5).Value 'Time DemPest.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'Delete empty rows End If nRows = nRows + 1 Loop Until nRows = LastRow + 1 'Close the source workbook without saving changes. WorkBk.Close savechanges:=False 'Use Dir to get the next file name. FileName = Dir() Loop 'Optimization off With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub 

这段代码的副本部分在一个工作簿/工作表中工作，但是当我试图在多个工作簿上展开时，没有运气。 请帮忙。