用VBA插入动态小计公式

Question

我编写了一个代码，该代码根据项目的代码长度插入工作表中。

我希望它更动态，并删除所有“ D”“ e”，例如范围公式中的参考。动态公式应根据“预算”范围的最后一列。

谢谢您的支持。

Sub Macro1() 
Dim LR, LastColumn, TotalColumn As Long
Dim Kirilim1, Kirilim2, Kirilim3, ColumnNumberFromTotal As Integer
Dim FoundCell As Range
Dim ColumnLettersFromTotal As String
LastColumn = ActiveSheet.Range("Budget").Columns.Count
Set FoundCell = Cells.Find(What:="TOTAL", After:=ActiveCell, LookIn:=xlValues, LookAt _
         :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                    False)
ColumnLettersFromTotal = Split(FoundCell.Address, "$")(1)
ColumnNumberFromTotal = Split(FoundCell.Address, "$")(2)

LR = (Cells(Rows.Count, 1).End(xlUp).Row)
Kirilim1 = LR
Kirilim2 = LR
Kirilim3 = LR

For i = LR To 1 Step -1



If Range("B" & i).Value = 8 Then

    Range("d" & i).Value = "=SUM(RC[1]:RC[" & (TotalColumn - ColumnNumberFromTotal + 1) & "])"

    Kirilim2 = Kirilim2 - 1
End If
        
If Range("B" & i).Value = 5 Then

    Range("d" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim3 & "C)"
    Range("e" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim3 & "C)"
    Range("f" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim3 & "C)"
    Range("g" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim3 & "C)"
    Range("h" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim3 & "C)"
    Range("i" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim3 & "C)"
    Range("j" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim3 & "C)"
    
    
    Kirilim3 = Kirilim2
    Kirilim2 = Kirilim2 - 1
End If

If Range("B" & i).Value = 2 Then


Range("d" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim1 + 1 & "C)"
Range("e" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim1 + 1 & "C)"
Range("f" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim1 + 1 & "C)"
Range("g" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim1 + 1 & "C)"
Range("h" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim1 + 1 & "C)"
Range("i" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim1 + 1 & "C)"
Range("j" & i).Value = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim1 + 1 & "C)"

                  
    Kirilim3 = i - 1
    Kirilim2 = i - 1
    Kirilim1 = i - 1

End If

Next i


End Sub

Answer 1

这是未来参考的动态代码和示例文件...

Sub AutoSubtotal()
Dim LR, LastColumn As Long
Dim Kirilim1, Kirilim2, Kirilim3, RowNumberFromTotal, ColumnNumberFromTotal As Integer
Dim FoundCell As Range
Dim ColumnLettersFromTotal As String
LastColumn = ActiveSheet.Range("Budget").Columns.Count
Set FoundCell = Cells.Find(What:="TOTAL", After:=ActiveCell, LookIn:=xlValues, LookAt _
         :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                    False)
ColumnLettersFromTotal = Split(FoundCell.Address, "$")(1)
RowNumberFromTotal = Split(FoundCell.Address, "$")(2)
ColumnNumberFromTotal = FoundCell.Column
LR = (Cells(Rows.Count, 1).End(xlUp).Row)
Kirilim1 = LR
Kirilim2 = LR
Kirilim3 = LR

For i = LR To 1 Step -1



If Len(Range("A" & i).Value) = 8 Then

    Range(ColumnLettersFromTotal & i).Value = "=SUM(RC[1]:RC[" & (LastColumn - ColumnNumberFromTotal) & "])"

    Kirilim2 = Kirilim2 - 1
End If
        
If Len(Range("A" & i).Value) = 5 Then
    
    For j = 0 To (LastColumn - ColumnNumberFromTotal)
    
        Cells(i, ColumnNumberFromTotal + j).Formula = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim3 & "C)"
    
    Next j
    
    Kirilim3 = Kirilim2
    Kirilim2 = Kirilim2 - 1
End If

If Len(Range("A" & i).Value) = 2 Then

For j = 0 To (LastColumn - ColumnNumberFromTotal)
    
    Cells(i, ColumnNumberFromTotal + j).Formula = "=SUBTOTAL(9,R" & Kirilim2 + 1 & "C:R" & Kirilim1 + 1 & "C)"

Next j
                  
    Kirilim3 = i - 1
    Kirilim2 = i - 1
    Kirilim1 = i - 1

End If

Next i


End Sub