Extract Multiple Rows into a Limited Template based on Multiple Criterias

Question

I have an issue in extracting from "Datadump" into several continuous "Template" (as the template can only contain 10 rows of item).

Here are my intentions:

1. From the data dump (sample above), is it possible to automatically extract the appropriate value into the Template with a maximum of 10 rows for each set of Template. And then colour-code those that have been printed to the Template. !-Template] These are the Template (Payment Voucher) limitations:

   a. Each template contains the data from only 1 (one) day

If in 1st January 2020 & 2nd January 2020, there are 5 transactions /day, there would have to be 2 Templates (1 for each day).

b. Each Template should only be from 1 Source

So if in 1st January 2020 & 2nd January 2020, there are 5 transactions/day from each Source A & B, there would be 4 Templates (1 for each source/day).

c. Each template could only contain 10 lines.

So if in 1st January 2020 & 2nd January 2020, there are 11 transactions/day from each Source A & B, there would be 8 Templates (2 for each source/day).

I have also attached a Before and After for reference :)

Before:

!-Before]

!-Template]

After:

!-After]

!-Voucher Page 1]

!-Voucher Page 2]

Since I am new to VBA, I would have no issue with the inputs to their appropriate places and to colour code. But I am still learning about the loop function that I believe would be required for this?

Any help would be much appreciated!

@Edit:

Values for the templates are:

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

Here are the codes that I could come up with for now (Trying to break the process down)

@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

I believe I would not have an issue with the colour coding but it seems that the data extraction is the main issue...

Any help would be appreciated!

@edit edit edit: Unfortunately could not make the image appears as it requires at least 10 reps. But if you try to see from the image example, I think it would provide much clarification.

Answer 1

An example for multi criteria matching is in Multiple Criteria Match/Index VBA Across two sheets

The multi criteria matching is in the lines

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

where the And connects the multiple criteria, in this case 2 criteria. And is the logical AND function, in excel are available 3 other logical operators OR, XOR and NOT ( https://www.ablebits.com/office-addins-blog/2014/12/17/excel-and-or-xor-not-functions/ ) that can also be used for multi criteria matching. The main structure for comparing and matching is If

In the code are used two nested loops, one loops through row 1 and 3 of sheet1 the other loops through row 1 and 3 of sheet2, in the 'core' of these two nested loopes the comparing, matching is performed. So if you want to loop through 2 rows of two sheets use the following :

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

Herllo albertd,

Just in case you may have missed it, I posted a fairly thorough answer for you here last week.

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

A few minor things might be missing, but having read through the comments here, I expect you can do some minor mods to get things like the formatting.

I would have just put this in a comment, but I can only comment on my own questions. So to satisfy the forum etiquette, I will post my macro solution. The details can be seen at that excelfox link.

    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

( Your other cross posts, don’t have any answers, and i doubt they will get any, but just for completeness I will add the links..

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

Alan