基于多个条件将多行提取到有限模板中

Question

我在从“Datadump”提取到几个连续的“模板”时遇到问题（因为模板只能包含 10 行项目）。

这是我的意图：

1. 从数据转储（上面的示例）中，是否可以自动将适当的值提取到模板中，每组模板最多 10 行。然后对已打印到模板的内容进行颜色编码。 !-Template] 以下是模板（付款凭证）的限制：

   一个。每个模板仅包含 1（一）天

   的数据

如果在 2020 年 1 月 1 日和 2020 年 1 月 2 日，/天有 5 笔交易，则必须有 2 个模板（每天 1 个）。 p>

b.每个模板只能来自 1 个来源

因此，如果在 2020 年 1 月 1 日和 2020 年 1 月 2 日，每个来源 A 和 B 每天有 5 笔交易，则将有 4 个模板（每个来源每天 1 个） 。

c。每个模板只能包含 10 行。

因此，如果在 2020 年 1 月 1 日和 2020 年 1 月 2 日，每个来源 A 和 B 每天有 11 个交易，则将有 8 个模板（每个来源/天 2 个） 。

我还附上了之前和之后供参考:)

之前：

!-Before]

!-Template]

之后：

!-After]

!-Voucher Page 1]

!-Voucher Page 2]

由于我是 VBA 新手，因此我不会对适当位置的输入和颜色代码有任何问题。但我仍在学习我认为需要的循环功能？

任何帮助将不胜感激！

@编辑：

模板的值是：

1. Credit Source = Source + Source Name
2. Total = All values inside the voucher
3. Account = Item Code
4. Detail = Item Name
5. Unit Code = Unit Code
6. Value = Total Debit

这里是我现在可以想出的代码（试图打破这个过程）

@edit @edit

Sub learn()
Set wb = ThisWorkbook

Set dtws = Worksheets("Database")
Set wstr = Worksheets("trial")
Dim vcdate
vcdate = wstr.Cells(2, "B").Value
Dim vcsource
vcsource = wstr.Cells(2, "D").Value

Dim NoE As Long
Dim lmtcount As Long

'Limiting No. Of Entries

'With wstr
 '   .Cells(2, 1).Value = Application.WorksheetFunction.CountIfs(dtws.Range("A:A"), vcdate, dtws.Range("J:J"), vcsource)

 '   NoE = wstr.Cells(2, 1).Value

'If NoE < 11 Then
'    .Cells(2, 3).Value = NoE
'Else
'    .Cells(2, 3).Value = 10

'End If
'End With

'lmtcount = wstr.Cells(2, 3).Value

'MsgBox NoE
'End of Limiting No. Of Entries


'------------------------
'Inputting Appropriately
'------------------------

Set tempws = Worksheets("Template")

Dim lrow As Long
Dim Count1 As Long

For Count1 = 1 To 100
    lrow = tempws.Range("A" & Rows.Count).End(xlUp).Row
    'MsgBox lrow
    If lrow = 19 Then Exit For
    '-----------------------------------------
    'MsgBox dtws.Cells(Count1 + 1, "A").Value
    '-----------------------------------------
    'Cross-Check if the same date
    If CDate(dtws.Cells(Count1 + 1, "A").Value) > CDate(vcdate) Then Exit For
    '-----------------------------------------
    'Cross check error
    'MsgBox dtws.Cells(Count1 + 1, "A").Value
    'MsgBox dtws.Cells(Count1 + 1, "J").Value
    '-----------------------------------------
    If dtws.Cells(Count1 + 1, "J").Value2 = vcsource Then
        With tempws
            .Cells(lrow + 1, "A") = dtws.Cells(Count1 + 1, 2)
            .Cells(lrow + 1, "C") = dtws.Cells(Count1 + 1, 3) & " - " & dtws.Cells(Count1 + 1, 5)
            .Cells(lrow + 1, "G") = dtws.Cells(Count1 + 1, 6)
            .Cells(lrow + 1, "I") = dtws.Cells(Count1 + 1, 9)
        End With
       '-----------------------------------------
       'Colour Code
       '-----------------------------------------
       With dtws
            .Cells(Count1 + 1, 2).Interior.Color = 13998939
            .Cells(Count1 + 1, 3).Interior.Color = 13998939
            .Cells(Count1 + 1, 6).Interior.Color = 13998939
            .Cells(Count1 + 1, 9).Interior.Color = 13998939
        End With


    End If


Next Count1


With tempws
        .Cells(20, "I").Formula = "=sum(I10:I19)"
        .Cells(7, "C").Value = tempws.Cells(20, "I").Value
        .Cells(4, "J").Value = vcdate
        .Cells(6, "C").Value = vcsource

End With

'----------------------------------------
'Input Tracking Order
'----------------------------------------
lrowtr = wstr.Range("A" & Rows.Count).End(xlUp).Row
With wstr
    .Cells(lrowtr + 1, "A").Value = vcsource
    .Cells(lrowtr + 1, "B").Value = vcdate
    .Cells(lrowtr + 1, "C").Value = Count1
End With
'----------------------------------------
'End of Input Tracking order
'----------------------------------------

End Sub

我相信颜色编码不会有问题，但似乎数据提取是主要问题......

任何帮助将不胜感激！

@edit 编辑编辑： 不幸的是无法使图像出现，因为它需要至少 10 次重复。但是，如果您尝试从图像示例中查看，我认为它会提供很多说明。

Answer 1

多条件匹配的示例在Multiple Criteria Match/Index VBA Across two sheets

多条件匹配在行

If ThisWorkbook.Worksheets("Sheet2").Cells(s, 1).Value = ID And ThisWorkbook.Worksheets("Sheet2").Cells(s, 2).Value = Activity Then
                ThisWorkbook.Worksheets("Sheet2").Cells(s, 3).Value = ThisWorkbook.Worksheets("Sheet1").Cells(r, 3).Value
            End If

And 连接多个条件，在本例中为 2 个条件。 And 是逻辑 AND 函数，在 excel 中可用 3 个其他逻辑运算符 OR、XOR 和 NOT (https://www.ablebits.com/office-addins-blog/2014/12/17/excel-and-or-xor-not-functions/) 也可用于多条件匹配。比较匹配的主要结构是If

在代码中使用了两个嵌套循环，一个循环通过 sheet1 的第 1 行和第 3 行，另一个循环通过 sheet2 的第 1 行和第 3 行 em>，在这两个嵌套循环的“核心”中执行比较、匹配。因此，如果您想遍历 2 行，每行两张纸，请使用以下命令：

For r = 2 To ThisWorkbook.Worksheets("Sheet1").UsedRange.Rows.Count

          ... 

        For s = 2 To ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows.Count

           ...

        Next s
    Next r

Answer 2

你好，阿尔伯特，

以防你可能错过了，上周我在这里为你发布了一个相当彻底的答案。

http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias?p=11847#post11847 http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11846&viewfull=1#post11846

可能会遗漏一些小东西，但在阅读完此处的 cmets 后，我希望您可以做一些小修改来获得格式等内容。

我本来只想把它放在评论中，但我只能评论我自己的问题。所以为了满足论坛礼仪，我将发布我的宏解决方案。详细信息可以在那个 excelfox 链接上看到。

    Option Explicit
    Sub DoItForADay()
    Rem 1 Worksheets info
    Dim WsTp As Worksheet, WsDta As Worksheet, WsSmry As Worksheet
     Set WsTp = ThisWorkbook.Worksheets("Template"): Set WsDta = ThisWorkbook.Worksheets("Datadump"): Set WsSmry = ThisWorkbook.Worksheets("Summary")
    Rem 2 The days and source list
    ' 2a) Put all info in an array
    Dim LrDta As Long: Let LrDta = WsDta.Range("A" & WsDta.Rows.Count & "").End(xlUp).Row
    Dim arrAllDts() As Variant           '  In the naxt line, the  .Value  Property ( method ) , is used to return in one go all  Values  in the range.  They are returned as a field, ( array ) of values in  held in  Variant  type  elements.  So we must use Variant for the  Dim ing  of the type of our Elements, or else the next code line will error , with a  Mismatch error
     Let arrAllDts = WsDta.Range("A4:M" & LrDta & "").Value '  I am adding  column M  for my own amusement
    ' 2b)

    ' 2c) make an array with all unique identifier for each voucher
    Dim Cnt As Long
        For Cnt = 1 To UBound(arrAllDts(), 1) ' Looping effectively from forth row until last row in  Datadump
    Dim Idt As String
         Let Idt = arrAllDts(Cnt, 1) & "_" & arrAllDts(Cnt, 8) & " - " & arrAllDts(Cnt, 9) '  I am adding a  "_"  to in between the   date   and   source info  : Later I can split the   unique identifiers  string by this  "_"  in order to get the date and souce info
         Let arrAllDts(Cnt, 13) = Idt
        Dim strDtsSrc As String
            If InStr(1, strDtsSrc, Idt, vbBinaryCompare) = 0 Then
             Let strDtsSrc = strDtsSrc & Idt & "###"
            Else
            ' case we already have the date in our string,  strDts
            End If
        Next Cnt
     Let strDtsSrc = Left(strDtsSrc, (Len(strDtsSrc) - 3)) '  take off the last space  "###"  which we do not need
     'Debug.Print strDtsSrc
    ' 2d)
    Dim arrUnicDtsSrc() As String
     Let arrUnicDtsSrc() = Split(strDtsSrc, "###", -1)
     Let Worksheets("arrUnicDtsSrc").Range("A1").Resize(1, (UBound(arrUnicDtsSrc()) + 1)).Value = arrUnicDtsSrc()      '    arrUnicDtsSrc().jpg  --- https://imgur.com/QX1bJMB
     Worksheets("arrUnicDtsSrc").Columns.AutoFit
     Let Worksheets("arrAllDts").Range("A4:M" & LrDta & "").Value = arrAllDts()
     ' The next code line can be removed to get all the 19 worksheets
     ReDim arrUnicDtsSrc(0 To 0): Let arrUnicDtsSrc(0) = "01.01.2020_99909900 - A" ' ***** I am limiting it to the first unique identifier, ( 01.01.2020_99909900 - A ) just for demo purposes. If you remove this line,  then you will see that all dates and sources  will be considered
    Rem 3                               ' === Main Outer loop ============================================================
    Dim Stear As Variant    '   For Each  unique identifier  . In VBA,
        For Each Stear In arrUnicDtsSrc() ' Doing stuff For Each  unique identifier
        '3a) work out how many rows and which row indicies with the current unique identifier
        Dim DteSrcRwCnt As Long
            For Cnt = 1 To UBound(arrAllDts(), 1) ' ----------------------Going through all data rows
             If arrAllDts(Cnt, 13) = CStr(Stear) Then ' I am looking for rows in the main datadump that have the current unique identifier
            '3a)(i) counting rows
                                                                               ' Debug.Print Cnt + 3 & " " & arrAllDts(Cnt, 13)
              Let DteSrcRwCnt = DteSrcRwCnt + 1  '  counting the rows for the current unique identifier
             '3a)(ii) get the (row) indicies for the current unique identifier. Later i need the row number of all the rows corresponding to the current unique identifier
             Dim strRws As String
              Let strRws = strRws & Cnt + 3 & " " ' I later wont the actual row in the datadump worksheet, so that is 3 higher than the "row" number in  arrAllDts()  because I captured just the range from the 4th row  --    "A4:M........
             Else
             End If
            Next Cnt                              ' ----------------------Going through all data rows
         Let strRws = Left(strRws, (Len(strRws) - 1))   ' Take of last  " "  which I do not need
        Dim arrRws() As String ' The VBA string function returns field of string type elements. So I must Dim my array elements appropriately
         Let arrRws() = Split(strRws, " ", -1, vbBinaryCompare) ' This gives us an array which is the row numbers  in the  Datadump  for this unique identifier
         Let ThisWorkbook.Worksheets("arrRws").Range("A1").Resize(1, (UBound(arrRws()) + 1)).Value = arrRws() '   arrRws().JPG - https://imgur.com/HDgpyQq                          -
         ThisWorkbook.Worksheets("arrRws").Columns.AutoFit
        '3b) In the  "Magic Code line"  below we need a  "vertical" array     https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
        Dim arrRwsT() As Long
         ReDim arrRwsT(1 To UBound(arrRws()) + 1, 1 To 1) ' a  "Vertical"  1 column array
            For Cnt = 1 To UBound(arrRws()) + 1
             Let arrRwsT(Cnt, 1) = arrRws(Cnt - 1)
            Next Cnt
        Let ThisWorkbook.Worksheets("arrRwsT").Range("A1:A" & UBound(arrRws()) + 1 & "").Value = arrRwsT()  '                             -         arrRwsT().JPG - https://imgur.com/syf0PaZ
        Rem 4 Make Vouchers for current unique identifier, Stear
        ' 4a)
        Dim arrVouch() As Variant    '     https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
         Let arrVouch() = WsTp.Range("A1:K24").Value
        ' 4b) An array just containing the rows for the current Idt
        Dim Clms() As Variant: Let Clms() = Evaluate("=Column(A:N)")    '   {1, 2, 3, 4......14} -   Clms().jpg  -  https://imgur.com/xHlUeH9
        Dim arrDtsSrc() As Variant  '    For   "Magic Code line"     https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
         Let arrDtsSrc() = Application.Index(WsDta.Cells, arrRwsT(), Clms())  ' - --"Magic Code line"      -  arrDtsSrc().JPG : https://imgur.com/0c8SgIn
         Let ThisWorkbook.Worksheets("arrDtsSrc").Range("A1").Resize(UBound(arrDtsSrc(), 1), UBound(arrDtsSrc(), 2)).Value = arrDtsSrc() '                             -         arrRwsT().JPG - https://imgur.com/syf0PaZ
        Dim RwCnt As Long: Let RwCnt = 1: Let Cnt = 1
        ' 4c)
            Do While RwCnt < DteSrcRwCnt + 1 ' ............................................
                Do While Cnt < 11 ' _________________________________|
                 '   Fill in values in Voucher Array
                 Let arrVouch(Cnt + 9, 1) = "'" & arrDtsSrc(RwCnt, 2)   '  The extra   "'"   is one way to keep the leading 0s
                 Let arrVouch(Cnt + 9, 4) = arrDtsSrc(RwCnt, 3)    '   Detail  ( Item )
                 Let arrVouch(Cnt + 9, 7) = arrDtsSrc(RwCnt, 4)    '   Unit Code
                 Let arrVouch(Cnt + 9, 9) = arrDtsSrc(RwCnt, 11)    '   Value
                 Let Cnt = Cnt + 1
                 Let RwCnt = RwCnt + 1
                Loop ' While Cnt < 11 ' ______________________________|
             Let arrVouch(6, 3) = Split(Stear, "_", 2, vbBinaryCompare)(1) ' The second array element (1) is  source code & source name  ( The first array element (0) is the date )
             Let arrVouch(4, 10) = Split(Stear, "_", 2, vbBinaryCompare)(0) ' The first array element (0) is the date
             Let Cnt = 1                       ' back to first row for a template
         '4d) Information to the summary sheet.
            Dim NxtVch As Long: Let NxtVch = WsSmry.Range("A" & WsSmry.Rows.Count & "").End(xlUp).Row
             Let WsSmry.Range("A" & NxtVch + 1 & "").Value = "V" & Format(NxtVch, "0000")
             Let WsSmry.Range("B" & NxtVch + 1 & "").Value = Split(Stear, "_", 2, vbBinaryCompare)(0)
             WsSmry.Hyperlinks.Add Anchor:=WsSmry.Range("C" & NxtVch + 1 & ""), Address:="", SubAddress:="V" & Format(NxtVch, "0000") & "!A1", TextToDisplay:="Go To Sheet"
         '4e)  Add next voucher
             WsTp.Copy After:=WsDta
             Let ActiveSheet.Name = "V" & Format(NxtVch, "0000")
             Let ThisWorkbook.Worksheets("arrVouch").Range("A1").Resize(UBound(arrVouch(), 1), UBound(arrVouch(), 2)).Value = arrVouch() '                             -         arrRwsT().JPG - https://imgur.com/syf0PaZ
             Let ActiveSheet.Range("A1").Resize(UBound(arrVouch(), 1), UBound(arrVouch(), 2)).Value = arrVouch()
             Let arrVouch() = WsTp.Range("A1:K24").Value  ' get a new template array

            Loop ' While RwCnt < DteSrcRwCnt ' .............................................

         Let DteSrcRwCnt = 0 ' ready for next Idt Stear
        Next Stear         ' === Main Outer loop =========================================================================

    End Sub

（您的其他交叉帖子，没有任何答案，我怀疑他们会得到任何答案，但为了完整起见，我将添加链接..

http://www.vbaexpress.com/forum/showthread.php?66589-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias https://www.myonlinetraininghub.com/excel-forum/vba-macros/extract-multiple-rows-into-a-limited-template-based-on-multiple-criterias https://chandoo.org/forum/threads/extract-multiple-rows-into-a-limited-template-based-on-multiple-criterias.43376/ https://www.excelforum.com/excel-programming-vba-macros/1301817-extract-multiple-rows-into-a-limited-template-based-on-multiple-criterias.html https://superuser.com/questions/1515592/extract-multiple-rows-into-a-limited-template-based-on-multiple-criterias

艾伦