动态求和

用查询设计器做的手工报表有时候行数是动态，对与行数不确定的情况需要用VBA来写程序实现，写代码还是我的最爱，不管是什么语言。刚刚写完我封装好的代码，觉得实在是牛b。秀下

Option Explicit

'p_queryRows:query起始行位置
'p_queryCol: query起始列位置
'p_conRows:workbook起始行位置
'p_conCol:workbook起始列位置
'p_ContentSheet: 报表的sheet名称
'p_deletePlace:从报表XX处开始检查是否有行项目，不为空则删除
'p_linesToReplace: 要被替换的列数

Sub insert(p_queryRows As Long, p_queryCol As Long, p_conRows As Long, p_conCol As Long, _
            p_ContentSheet As String, p_deletePlace As String, p_linesToReplace As Integer)
     Dim Count As Long                       '复制的列数
    '先将数据全部清除
    '选中要删除的区间C_deltePlace
      With Worksheets(p_ContentSheet).Range(p_deletePlace)
        While Worksheets(p_ContentSheet).Range(p_deletePlace).Value <> ""   '根据空行判断是否删除
            '选中删除
            Worksheets(p_ContentSheet).Range(p_deletePlace).Select
            Selection.EntireRow.Delete
        Wend
    End With
    With Worksheets("QUERY")
        '在query里不为空且没有达到最后一行,最后一行结束的标记为"结束"
        While .Cells(p_queryRows, p_queryCol).Value <> "" And .Cells(p_queryRows, p_queryCol).Value <> "结果"

            '报表里插入新行
             Worksheets(p_ContentSheet).Rows(p_conRows).insert Shift:=xlUp
             '改变颜色
            Worksheets(p_ContentSheet).Rows(p_conRows).Select
             With Selection.Interior
                .Color = RGB(255, 255, 255)
            End With
            '复制linesToReplace列
            For Count = 0 To p_linesToReplace - 1
                  Worksheets(p_ContentSheet).Cells(p_conRows, p_conCol + Count).Value = .Cells(p_queryRows, p_queryCol + Count).Value
            Next Count
            '更新要复制的行号
            p_queryRows = p_queryRows + 1
        Wend
    End With
    '引用合计结果
    Worksheets(p_ContentSheet).Range(p_deletePlace).Offset(-1, 3).Value = _
        Worksheets("QUERY").Cells(p_queryRows, p_queryCol + 3).Value
    Worksheets(p_ContentSheet).Range(p_deletePlace).Offset(-1, 4).Value = _
        Worksheets("QUERY").Cells(p_queryRows, p_queryCol + 3).Value
    Worksheets(p_ContentSheet).Range(p_deletePlace).Offset(-1, 5).Value = _
        Worksheets("QUERY").Cells(p_queryRows, p_queryCol + 3).Value

End Sub

Sub Main()
    insert 18, 3, 8, 4, "转让及无偿划出企业（资产）情况表", "D8", 8
    insert 22, 3, 13, 4, "转让及无偿划出企业（资产）情况表", "D13", 8
End Sub

又修改了下，如下，减少了一个参数

 Option Explicit
 Public insertNum As Long

'p_queryRows:query起始行位置
'p_queryCol: query起始列位置
'p_conRows:workbook起始行位置
'p_conCol:workbook起始列位置
'p_ContentSheet: 报表的sheet名称
'p_linesToReplace: 要被替换的列数

 Sub insert(p_queryRows As Long, p_queryCol As Long, p_conRows As Long, p_conCol As Long, _
            p_ContentSheet As String, p_linesToReplace As Integer)
   
     Dim Count As Long                       '复制的列数
    '先将数据全部清除
    '选中要删除的区间C_deltePlace
      With Worksheets(p_ContentSheet).Cells(p_conRows, p_conCol)
        While Worksheets(p_ContentSheet).Cells(p_conRows, p_conCol).Value <> ""   '根据空行判断是否删除
            '选中删除
            Worksheets(p_ContentSheet).Cells(p_conRows, p_conCol).Select
            Selection.EntireRow.Delete
        Wend
    End With
   
    With Worksheets("QUERY")
        '在query里不为空且没有达到最后一行,最后一行结束的标记为"结束"
        While .Cells(p_queryRows, p_queryCol).Value <> "" And .Cells(p_queryRows, p_queryCol).Value <> "结果"

            '报表里插入新行
             Worksheets(p_ContentSheet).Rows(p_conRows).insert Shift:=xlUp
            
             '改变颜色
            Worksheets(p_ContentSheet).Rows(p_conRows).Select
             With Selection.Interior
                .Color = RGB(255, 255, 255)
            End With
           
            '复制linesToReplace列
            For Count = 0 To p_linesToReplace - 1
                  Worksheets(p_ContentSheet).Cells(p_conRows, p_conCol + Count).Value = .Cells(p_queryRows, p_queryCol + Count).Value
            Next Count
            '更新赋值的行号
            insertNum = insertNum + 1
           
            '更新要复制的行号
            p_queryRows = p_queryRows + 1
        Wend
    End With
   
    '引用合计结果
    Worksheets(p_ContentSheet).Cells(p_conRows, p_conCol).Offset(-1, 3).Value = _
        Worksheets("QUERY").Cells(p_queryRows, p_queryCol + 3).Value
    Worksheets(p_ContentSheet).Cells(p_conRows, p_conCol).Offset(-1, 4).Value = _
        Worksheets("QUERY").Cells(p_queryRows, p_queryCol + 3).Value
    Worksheets(p_ContentSheet).Cells(p_conRows, p_conCol).Offset(-1, 5).Value = _
        Worksheets("QUERY").Cells(p_queryRows, p_queryCol + 3).Value
   
End Sub

Sub Main()
    insertNum = 0

    insert 18, 3, 8, 4, "转让及无偿划出企业（资产）情况表", 8
    insert 18 + 1 + insertNum, 3, 8 + 2 + insertNum, 4, "转让及无偿划出企业（资产）情况表", 8
End Sub