根据多个条件将行提取到有限的模板中

2024-7-11 • tag-icon

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

我的意图如下：

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

a. 每个模板仅包含来自1（一）天

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

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

因此，如果在 2020 年 1 月 1 日至 2020 年 1 月 2 日，每天有 5 笔交易来自各来源 A 和 B，那里将会是4 个模板（每个来源/天 1 个）。

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

因此，如果在 2020 年 1 月 1 日和 2020 年 1 月 2 日，11每天从来源 A 和 B 获得的交易数8 个模板（每个来源/天 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

以下是我现在能想到的代码（尝试分解该过程）

@编辑 @编辑

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

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

任何帮助，将不胜感激！

相关内容