【原】VBA【代码】工作表合并新技能：巧用数组字段定位函数，灵活整合分表内容到总表

快速浏览

实用案例

|日期控件||简单的收发存||收费管理系(Access改进版)|

|电子发票管理助手||电子发票登记系统(Access版)|

|文件合并||表格拆分||审计凭证抽查底稿|

|中医诊所收费系统(Excel版)||中医诊所收费系统(Access版)||银行对账单自动勾对|

|印章使用登记系统|

收费使用项目

|财务管理系统||工资薪金和年终奖个税筹划||新税法下工资表模版|

内容提要

• 巧用数组字段定位，灵活合并工作表|完整代码

1、在工作表“总材料表”里，命令按钮点击事件，调用汇总合并过程：

Private Sub CmdSum_Click()    Call mySumEnd Sub

2、在myModule里，mySum过程，汇总合并各分表数据到总表：

Sub mySum()    '//把其他表内容按照字段，汇总表总表    '//总表第一列是序号，其他字段应该是来自分表，数量不限,必须预先填好    Dim ws As Worksheet, wsSum As Worksheet    Dim lastRow As Long, lastCol As Long, rng As Range    Dim arr(), temp(), currTitle As String, currRow As Integer    Set wsSum = ThisWorkbook.Sheets("总材料表")    '//把总表标题以下清空    With wsSum        .UsedRange.Offset(1).Clear        lastCol = .UsedRange.Columns.Count        If lastCol < 2 Then            MsgBox "请在第一行填写汇总字段！"            Exit Sub        End If        '//把总表表头存入数组        ReDim arr(1 To lastCol, 1 To 1)        For i = 1 To lastCol            arr(i, 1) = .Cells(1, i)        Next    End With        '//循环所有工作表，把名称不为总表名称的工作表数据进行汇总    For Each ws In ThisWorkbook.Worksheets        If ws.Name <> wsSum.Name Then            With ws                lastRow = .UsedRange.Rows.Count                lastCol = .UsedRange.Columns.Count                                '//lastRow大于1,表示有数据，跳过没有数据的空表                If lastRow > 1 Then                                        '//把分表的数据装入数组temp                    temp = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))                    m = UBound(arr, 2)                    n = m + lastRow - 1                                        '//根据分表数据区域的大小，动态扩展数组arr                    ReDim Preserve arr(1 To UBound(arr), 1 To n)                                        '//循环arr各个字段，根据pxy函数取得分表中对应字段的位置，并把数据写入arr                    For i = 2 To lastRow                        arr(1, m + i - 1) = m + i - 2                        For j = 2 To UBound(arr)                            currTitle = arr(j, 1)                            currRow = 0                                                        '//跳过总表空字段                            If currTitle <> "" Then                                currRow = Pxy(temp, currTitle, 2)                            End If                                                        '//跳过在分表中不存在的字段                            If currRow > 0 Then                                arr(j, m + i - 1) = temp(i, currRow)                            End If                        Next                    Next                End If            End With        End If    Next        '//把数据写入工作表    With wsSum        Set rng = .Cells(1, 1).Resize(UBound(arr, 2), UBound(arr))        With rng            .Value2 = Application.WorksheetFunction.Transpose(arr)            .Borders.LineStyle = 1            .HorizontalAlignment = xlCenter            .Font.Name = "宋休"        End With    End With    MsgBox "Done!"End Sub

3、在myModule里，Pxy自定义函数，数组字段定位，关于这个函数，可参见案例文章【教程】自定义函数：Pxy数组字段定位函数：

Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0)    '**********************************    '//参数说明：    '//arr(),数组，可以是一维也可以是二维    '//FieldName，字段名，需要定位的字段名    '//arrType=0,表示一维数组    '//arrType=1,表示二维数组，查找第一列    '//arrType=2,表示二维数组，查找第一行    '**********************************    k = 0: t = 0    Select Case arrType    Case Is = 0        For i = LBound(arr) To UBound(arr)            k = k + 1            If arr(i) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 1        For i = LBound(arr, 1) To UBound(arr, 1)            k = k + 1            If arr(i, 1) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 2        For i = LBound(arr, 2) To UBound(arr, 2)            k = k + 1            If arr(1, i) = FieldName Then                t = 1                Exit For            End If        Next    End Select    If t = 1 Then        Pxy = k    Else        Pxy = 0    End IfEnd Function

~~~~~~End~~~~~~