Excel VBA自動對帳

Question

我有一個excel工作表，如下所示，該工作表列出了兩種交易類型-Advance Pmt Credit和Refill。 目的是調和這一點，並確保每筆預付款可抵免額由一組充值抵銷。

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列具有為每個“預付款”信用分配編號參考的公式； 第6和7列進行了一些檢查，以確保每個組加到0，並且一個組中僅存在1個預付款。

我需要通過在第4列（分組）中添加引用來對行進行分組，以便

1. 每組的總數應為0
2. 每個組只能包含一個“高級Pmt積分”
3. 規則2表示，如果列4是預付款信用，則列4中的值應與列5中的參考值相同。

我試圖編寫一個宏以自動在第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中分配它，然后開始將相同的ref分配給col 4中的第一個可用空白單元格，直到該組的總和為0； 如果“筆芯”的總和超過“預付款”信用額，則刪除最后更新的參考； 然后在第3列中找到下一個可用的空單元格並添加引用； 然后再次檢查總和...重復這些步驟，直到所有項目都平衡為止。

問題：宏運行平穩，直到形成約15組，但在第16次迭代中陷入無限循環。 如果將筆芯添加到組后，如果筆芯的總和超過“預付款”信用總額，則此邏輯將失敗。 我已經在這里上傳了工作簿。

您能否建議一個更好的算法來實現這一點-帶有或不帶有VBA。

感謝您的幫助和建議！

Answer 1

即使您對規則進行了解釋，但我仍然難以理解您的代碼的作用。 但是，我可以將您對行的分配匹配到第15組（這是您的代碼處理的最后一個組）。 我的代碼成功執行到第35組，但在第36組失敗了。稍后我將解釋原因。

我已經使用VBA在工作表中放置公式，但是僅當這些工作表是動態的並且公式值將更改時才使用。 這里似乎不是這樣，因此我放棄了對公式的使用。

我像您一樣使用N和O列。 我也使用列P，但僅用於幫助您確定如何處理組36故障。 我不會使用您的任何其他工作列。

像您一樣，我在第一遍將參考號分配給“高級Pmt信用”行，在第二遍將它們分配其他行到組。 這不是必需的，但我相信將兩個通道分開放置會使它們更清晰。

在將行分配給組時，我使用P列記錄運行總計。 由於您為P列指定了“總和檢查”標題，因此您可能打算這樣做。 分配給組的最后一行中的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