vba 如何在合并单元格中间插入1列并求等差列总和？

Question

想要实现的效果是在D、E、F、G、H之后插入一列，并计算各合并单元格总和，如在D后加入空白列后，计算d1+d2+d3的值。

在插入列时发现，使用录制宏后发现运行代码会变成插入三列，表格如下图所示，

Sub Macro2()
'
' Macro2 Macro
' 宏由 录制，时间: 2024/10/23

    Columns("H:H").Select
    Range("H3").Activate
    Selection.Insert Shift:=xlShiftToRight
End Sub

Answer 1

Sub vba_add_column_sum()  
    Dim iCount As Long
    Dim i As Long
    Dim LastCol As Long
    Dim varCol As Long
    Dim starNo As Long
    Dim mergeCount As Long
    '求和单元格位于第几行
    Dim sumCell
    '某列最后一个有值的行号
    Dim lastColunmVal As Long
    '填充列变量
    Dim fillColunmVar As String
        
    '求和结束列变量
    Dim endColunmVar
    
    
    '总活动列数
    LastCol = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
    MsgBox " 总活动列: " & LastCol
    
    iCount = InputBox(Prompt:="插入多少列?")
    starNo = InputBox(Prompt:="起始无关列数量？ ")
    mergeCount = InputBox(Prompt:="等差列数量？ ")
    sumCell = InputBox(Prompt:="求和单元格从第几行开始？")
    
    'loop to insert new column(s)
    '无关列3列，合并列3列，6列之后加新列就得+1
    varCol = starNo + mergeCount + 1
    
    For i = 1 To Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
     'For i = 1 To LastCol
     'MsgBox "varCol的值为" & varCol & "mergecount" & mergeCount & "分割字母 " & Split(Cells(3, varCol - mergeCount - 1).Address, "$")(1)
     'MsgBox " 最后一列: " & Range(Split(Cells(3, varCol - mergeCount - 1).Address, "$")(1) & "1")
     'MsgBox " 最后一列: " & IsEmpty(Cells(3, varCol - 1))

     If IsEmpty(Cells(3, varCol - 1)) Then
        Exit For
     End If
     
        Columns(varCol).EntireColumn.Insert
        '获取前一列有数据最后一行行号
        lastColunmVal = Sheet1.Range(Split(Cells(3, varCol - 1).Address, "$")(1) & Sheet1.Rows.Count).End(xlUp).Row
        
        '插入列列号
        fillColunmVar = Split(Cells(3, varCol).Address, "$")(1)
        
        '求和公式开始列号
        starColunmVar = Split(Cells(3, varCol - mergeCount).Address, "$")(1)
        
        '求和公式结束列号（等差3列，若求和只求等差前两列则-2，求三列的和则-1）
        endColunmVar = Split(Cells(3, varCol - 2).Address, "$")(1)
        
        '插入列后计算合并列和
        'MsgBox "公式:" & "=SUM(" & fillColunmVar & sumCell & ": " & endColunmVar & sumCell & ")"
        
        '求和列名
        Range(fillColunmVar & 2).Select
        Selection.Formula = Cells(1, varCol - mergeCount) & "求和"
        
        'Cells(sumCell, varCol).Select
        Range(fillColunmVar & sumCell).Select
        '插入求和公式
        'Selection.FormulaR1C1 = "=SUM(" & starColunmVar & sumCell & ": " & endColunmVar & sumCell & ")"
        Selection.Formula = "=SUM(" & starColunmVar & sumCell & ": " & endColunmVar & sumCell & ")"
        
        Range(fillColunmVar & sumCell).Select
        '填充求和列
        Selection.AutoFill Destination:=Range(fillColunmVar & sumCell & ":" & fillColunmVar & lastColunmVal), Type:=x1FillDefault
        
        '计算等差值，下一循环插入列
        varCol = varCol + mergeCount + 1
        'MsgBox " Column Count: " & varCol

        LastCol = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
        Next i
        

  
End Sub