我有一个excel工作表，如下所示，它列出了两种类型的交易 - Advance Pmt Credit＆amp;笔芯。目标是协调这一点，并确保每个提前Pmt信贷被一组补货抵消。
Date Description Amount Grouping AutoRef Sum Check Ref Chk
12/7/2012 Refill (20,000.00) advpmtcrdt1 0 Ok
12/7/2012 Advance Pmt Credit 20,000.00 advpmtcrdt1 advpmtcrdt1 0 Ok
12/9/2012 Refill (20,000.00) advpmtcrdt2 0 Ok
12/9/2012 Refill (40,000.00) advpmtcrdt2 0 Ok
12/10/2012 Refill (20,000.00) advpmtcrdt2 0 Ok
12/10/2012 Advance Pmt Credit 80,000.00 advpmtcrdt2 advpmtcrdt2 0 Ok
12/11/2012 Refill (40,000.00) advpmtcrdt4 -100000 Ok
12/11/2012 Refill (40,000.00) advpmtcrdt4 -100000 Ok
12/11/2012 Refill (20,000.00) advpmtcrdt3 0 Ok
12/11/2012 Advance Pmt Credit 20,000.00 advpmtcrdt3 advpmtcrdt3 0 Ok
12/12/2012 Refill (20,000.00) advpmtcrdt4 -100000 Ok
实际数据从第1列到第3列;我使用第4列将每条记录分配给一个组;第5栏有公式为每个Advance Pmt Credit分配编号ref;第6栏和第6栏7进行了一些检查，以确保每个组添加到0，并且组中只存在1个Advance Pmt Credit。
我需要通过在第4列（分组）中添加引用来对行进行分组，以便
我尝试编写一个宏来自动添加col 4中的引用：
Sub AutoFill()
Dim Ref As String
Dim rng As Range
Application.ScreenUpdating = False
With Application.WorksheetFunction
On Error Resume Next
Ref = .VLookup("Unresolved", Range("FullList"), 3, 0)
If Err.Number = "1004" Then Ref = .VLookup("Free", Range("List"), 2, 0)
While .Index(Range("AB:AC"), .Match(Ref, Range("AB:AB"), 0), 1) <> Ok
On Error Resume Next
Ref = .VLookup("Unresolved", Range("FullList"), 3, 0)
If Err.Number = "1004" Then Ref = .VLookup("Free", Range("List"), 2, 0)
.Index(Range("N:O"), .Match(Ref, Range("O:O"), 0), 1) = Ref
Set rng = Range("N1").End(xlDown).Offset(1, 0)
While .SumIf(Range("N:N"), Ref, Range("L:L")) <> 0
If .CountA(rng) = 0 Then
rng.Value = Ref
If .Sum(Range("P:P")) < 0 Then rng.Clear
End If
Set rng = rng.Offset(1, 0)
Wend
Wend
End With
Application.ScreenUpdating = True
End Sub
宏是这样做的：检查下一个未使用的ref，根据上面给出的规则3在col 4中分配它，然后开始为col 4中的第一个可用空白单元分配相同的ref，直到该组的总和是0;如果Refills的总和超过Advance Pmt信用额，则删除最后更新的ref;然后在col 3中找到下一个可用的空单元格并添加ref;然后再次检查总和...重复这些步骤，直到所有项目均衡。
问题：宏运行平稳，直到它产生了大约15个组，但在第16次迭代中导致无限循环。如果在我们向组添加补充后补充的总和超过Advance Pmt信用总额，则此逻辑将失败。我上传了工作簿here。
你能否建议一个更好的算法来实现这个目标 - 无论是否有VBA。
感谢您的帮助＆amp;建议！
答案 0 :(得分：0)
即使您对规则有所解释，我也发现很难破译您的代码所做的事情。但是，我可以将您的行分配匹配到组15，这是您的代码处理的最后一个。我的代码成功到35组，但在36组时优雅地失败。我将在后面解释原因。
我已经使用VBA在工作表中放置公式，但仅当这些工作表是动态的并且公式值将发生变化时。这似乎并非如此，所以我放弃了对公式的使用。
我像你一样使用N和O列。我也使用P列，但仅用于帮助您确定如何处理组36故障。我不使用你的任何其他工作栏。
与您一样，我在第一次传递时将参考号分配给“Advance Pmt Credit”行，并在第二次传递时将其他行分配给组。这不是必要的，但我相信保持两个通道分开使它们更清晰。
当我将行分配给组时，我使用列P记录运行总计。既然你已经给P列标题为“Sum Check”，那么也许你想要做同样的事情。 P列中与分配给组的最后一行的值始终为零。
我在第36组失败了，因为在达到运行总计为零之前，我用尽了行来分配给组。查看更新的工作表，我不清楚应该将哪些行分配给组36。
我认为最简单的方法是创建一份“Report.xlsb”。从副本中删除U到X列，并将宏AutoFill替换为我的。
试试我的宏。我对代码提供的帮助很少，因为我不想花时间解释可能不合适的解决方案。如果您认为它符合您的要求，我很乐意解释。
Option Explicit
Sub AutoFill()
Const ColDesc As Long = 5
Const ColAmount As Long = 12
Const ColRefAll As Long = 14
Const ColRefAPC As Long = 15
Const ColTotal As Long = 16
Const RefPrefix As String = "advpmtcrdt"
Dim NumRefNext As Long
Dim RefCrnt As String
Dim Rng As Range
Dim RowCrnt As Long
Dim RowPrev As Long
Dim TotalCrnt As Double
With Worksheets("AS-Track")
' Allocate reference to each "Advance Pmt Credit" row
' ===================================================
RowPrev = 1
NumRefNext = 1
' Find first "Advance Pmt Credit" if any
Set Rng = .Columns(ColDesc).Find(What:="Advance Pmt Credit", _
After:=Cells(RowPrev, ColDesc), _
SearchDirection:=xlNext)
If Rng Is Nothing Then
' No "Advance Pmt Credit" in worksheet
Call MsgBox("""Advance Pmt Credit"" not found", vbOKOnly)
Exit Sub
End If
' At least one "Advance Pmt Credit" row found. On entry to this loop
' Rng addresses the first "Advance Pmt Credit" row. For each subsequent
' loop, Rng addresses the followint "Advance Pmt Credit" row.
Do While True
If Rng.Row <= RowPrev Then
' Have looped so all "Advance Pmt Credit" rows have reference
Exit Do
End If
RowCrnt = Rng.Row
' Allocate next reference to this "Advance Pmt Credit" row.
.Cells(RowCrnt, ColRefAPC) = RefPrefix & NumRefNext
NumRefNext = NumRefNext + 1
RowPrev = RowCrnt
Set Rng = .Columns(ColDesc).FindNext(Rng)
Loop
' Allocate other rows to "Advance Pmt Credit" groups
' ==================================================
' This loop could have been merged with previous loop but I
' believe code is more easily understood if they are separate.
' Have exited above loop with Rng addressing first
' "Advance Pmt Credit" row.
RowPrev = 1
Do While True
If Rng.Row <= RowPrev Then
' Have looped so "Advance Pmt Credit" rows have been grouped
' with other rows.
Exit Do
End If
RowCrnt = Rng.Row
' This is a "Advance Pmt Credit" row. Group it with previous
' non-"Advance Pmt Credit" rows that are not part of another
' group until the group total is zero.
RefCrnt = .Cells(RowCrnt, ColRefAPC).Value
.Cells(RowCrnt, ColRefAll).Value = RefCrnt
TotalCrnt = .Cells(RowCrnt, ColAmount).Value
With .Cells(RowCrnt, ColTotal)
.NumberFormat = "#,##0.00-"
.Value = TotalCrnt
End With
Do While True
RowCrnt = RowCrnt - 1
If RowCrnt = 1 Then
Call MsgBox("I am trying to create the group " & RefCrnt & _
" but I reached row 1 with a running total of " & _
Format(TotalCrnt, "#,##0.00-"), vbOKOnly)
Exit Sub
End If
If .Cells(RowCrnt, ColRefAll).Value = "" Then
' This row has not been allocated
.Cells(RowCrnt, ColRefAll).Value = RefCrnt
TotalCrnt = TotalCrnt + .Cells(RowCrnt, ColAmount).Value
With .Cells(RowCrnt, ColTotal)
.NumberFormat = "#,##0.00-"
.Value = TotalCrnt
End With
If Abs(TotalCrnt) < 0.009 Then
' The total of this group is zero (within the error associated
' with holding decimal values as binary).
Exit Do
End If
End If
Loop
RowPrev = Rng.Row
Set Rng = .Columns(ColDesc).FindNext(Rng)
Loop
End With
End Sub