的 !!!更新!!!

Question

我是VBA编码的初学者，所以请耐心等待。手头的问题是我需要创建一个“自动化”且易于使用的报表创建方法。

我尝试过不同的VLOOKUP，MATCH＆amp; INDEX配置等，似乎没有任何东西像我需要的那样工作。我已经搜索并搜索了一个解决方案，但所有答案似乎都是特定于案例的，他们只是在解决我的问题。

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

E.g。我可以在1.1.2017和2017年1月31日之间搜索“ProductABC”的所有条目，并将数据保存为新的单独报告文件。

产品和产品编号存储在报告创建工作簿中的子产品“产品列表”中。

源文件夹包含按年份排序的报告：“... \ Products \ Reports \ 2017.xlsx”报告数据显示如下：

      A           B             C           D            E
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

报告创建表看起来大致如下：

       A                 B
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

在其他一些失败的实验中，我在网上找到了这段代码，并试图摆弄它以满足我的需求。我知道它并不完整，可能甚至不能满足我的需求，但这是我所接受的：

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

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

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

的 !!!更新!!!

0 个答案: