在Excel中使用VBA創建應計模板

Question

我正在創建一個自動應計模板。 它具有以下要求：

• 數據必須首先按帳戶分類，然后再按業務部門分類。 必須為每個業務部門插入兩組的抵銷行：帳戶“ 101”的行和所有其他帳戶的行。
• 抵銷線應反映以上適當的業務部門。
• 如果用於“ 101”組，則抵銷行的帳號應為“ 750”，如果用於所有其他帳戶組，則應為“ 780”。
• 抵銷行的交易類型應始終為“ 25”。
• 抵消線上的金額應為上述組的負小計，這意味着它應將上述各行“清零”。

我的代碼當前按帳戶然后按業務部門對數據進行排序。 它正確插入業務部門。 它還在抵消行上為事務處理類型正確插入“ 25”。 它做不到的是說“如果上面的線是101，那么750，或者如果上面的線不等於101，然后是780。它也不能為上述組創建一個負的小計。

如果希望查看最終結果，請查看“最終結果”選項卡。

我已經把文件貼在這里了 。

Sub accrualMacro()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'CLEAR ALL FILTERS
With ActiveSheet
.AutoFilterMode = False
End With

'FILTER AND SORT
Rows("10:10").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("ACCRUAL TEMPLATE").AutoFilter.Sort.SortFields. _
    Clear
ActiveWorkbook.Worksheets("ACCRUAL TEMPLATE").AutoFilter.Sort.SortFields. _
    Add Key:=Range("B10"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ACCRUAL TEMPLATE").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
ActiveWorkbook.Worksheets("ACCRUAL TEMPLATE").AutoFilter.Sort.SortFields. _
    Clear
ActiveWorkbook.Worksheets("ACCRUAL TEMPLATE").AutoFilter.Sort.SortFields. _
    Add Key:=Range("A10"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ACCRUAL TEMPLATE").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply

With Range("A10", Range("A" & Rows.Count).End(xlUp))
    .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    .Offset(2, -1).SpecialCells(xlCellTypeConstants).Offset(,     1).ClearContents
    .Offset(, -1).EntireColumn.Delete
    .EntireColumn.RemoveSubtotal
End With

End With

'INSERT BLANK ROWS AT
Dim Col As Variant
Dim BlankRows As Long
Dim lastRow As Long
Dim R As Long
Dim StartRow As Long

    Col = "B"
    StartRow = 10
    BlankRows = 1

    lastRow = Cells(Rows.Count, Col).End(xlUp).Row

With ActiveSheet
For R = lastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "101" And .Cells(R + 1, Col) <> "101" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With

'new method below
With ActiveSheet.Range("A10:A" & lastRow)
  Set myrange = .SpecialCells(xlCellTypeBlanks)
  If Not myrange Is Nothing Then
 myrange.FormulaR1C1 = "=R[-1]C"
 .Value = .Value
End If
End With

With ActiveSheet.Range("C10:C" & lastRow)
  Set myrange = .SpecialCells(xlCellTypeBlanks)
If Not myrange Is Nothing Then
 myrange.FormulaR1C1 = "25"
End If
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Answer 1

我不確定我是否正確理解了100％。 但是在我看來，您正在尋找以下幾行代碼來完成您的宏：

Dim lngStartRow As Long
Dim lngEndRow As Long

lngStartRow = 11

For lngEndRow = 11 To Sheet1.Cells(Sheet1.Rows.Count, Col).End(xlUp).Row
    If Trim(Sheet1.Cells(lngEndRow, 4).Formula) = vbNullString Then
        Sheet1.Cells(lngEndRow, 4).Formula = "=-SUM(D" & lngStartRow & ":D" & lngEndRow - 1 & ")"
        lngStartRow = lngEndRow + 1
    End If
Next lngEndRow

基本上， For ... Next循環遍歷各行並檢查空行（從第一行開始為11）。 如果有空白行（在D列中），則將使用SUM公式來匯總所有上述單元格。 此外，將下一個SUM的“新起點”設置為下一個可用行。 重復該過程，直到匯總了D列中的所有行（最后一個塊除外）為止。 如果您還希望包括最后一個塊，則必須使用+1擴展循環。