VBA应用

01 工作表

参照《模板表》批量生成工作表并填写指定内容

一个关于样表拆分和数据填入的问题

Question：

有一个资金划单的明细表，它是汇总的一个表格，我现在要把"交易金额"、"摘要"这两个信息，以"单位"为区分，填到分公司表里，单位太多了，要是能不能有快捷的方法，我这些是需要按公司打印出来的？

这个是资金划单的"汇总表部分"截图：

这个是要填写到"分公司"的表：

最终要把摘要和金额填到这里，一个单位一个表：

Answer1：

根据描述，其实可以把主要动作分成两个：一个是按照单位拆分表，一个是数据的填入！

工作表的拆分：之前写过一个类似的过程，🔗工作表按指定列-批量拆分成工作簿或工作表，不过里面只是拆分，没有数据填入"分公司表"的过程。工作表拆分的这个动作我们直接参考这个过程就可以！

Answer2：

数据填入：因为所需要填写的内容，不管是在“明细汇总表”、还是“分公司表”，列位置和首行的位置都是固定的，可以先依据“单位”名称添加多个新表，新表样本就参考(复制)“分公司表”，然后在增加一个循环判断的过程、给“目标表”的固定位置赋值就可以了！

运行视频：

源码下载：

VBA实现过程：

1.用Application.InputBox和用户交互，让她/他来自定义选择需要拆分的内容所在列；
2.Colection有序集合的特点，保留列内容的不重复值；
3.循环集合的元素，添加新表、重命名；
4.主程序逻辑实现过程

①循环添加的新表，复制"模版表"粘贴到新表中，
②嵌套一个循环，判断"汇总明细表"内的'单位'是否和新表名称一致，如果一致就将需要填入的值，赋值到该"目标表"中，

5.结束！

示例代码

复制成功!


Sub 工作表按模板复制拆分()
    '----------------------------------------------------
     '自定义各数据类型
    Dim Splitcol, rng As Range
    Dim Colnum As Integer, Arr, Lastrow, i, Shtindex, Only As New Collection

    On Error Resume Next
    '-----------------------------------------------------
    '指定需要的拆分条件列
    Set Splitcol = Application.InputBox("选择单位所属的单元格区域", "选择单位", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    If WorksheetFunction.CountA(Splitcol.EntireColumn) = 0 Then MsgBox "选择的列内容为空": Exit Sub
    '-----------------------------------------------------
    On Error GoTo 0


    With Splitcol.Parent
        Colnum = Splitcol.Column
        Lastrow = .UsedRange.Rows.Count

        '-------------------------------------------------
        '对需要拆分的条件列的值剔除重复值，利用Colection有序集合的成员不能存在重复内容的作用
        Arr = .Range(.Cells(7, Colnum), .Cells(Lastrow, Colnum))
        On Error Resume Next   '在本实例中为 I列"单位"的不重复值
        For i = 1 To Lastrow - 7
            If Len(Arr(i, 1)) > 0 Then Only.Add CStr(Arr(i, 1)), CStr(Arr(i, 1))
        Next i


        Application.ScreenUpdating = False '关闭屏幕更新，加快执行速度
        Application.DisplayAlerts = False  '关闭显示特定的警告和消息，删除已经存在相同名字的工作表时，不弹出消息

        For i = 1 To Only.Count  '循环包含"名称"的集合，依次添加新工作表，并命名
            Err.Clear
            Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Sheets(Sheets.Count).Name = Only(i)
            If Err.Number > 0 Then Sheets(Only(i)).Delete: Sheets(Sheets.Count).Name = Only(i)

        Next i

        '------------------------------------------------
        '遍历拆分出的工作表，把明细表众的相应内容拆分到各分表中

        For i = 1 To Only.Count
            Shtindex = 7
            Sheets("表模板").Cells.Copy  '模版表复制
            Sheets(Only(i)).Paste        '新表粘贴
            For Each rng In Splitcol     '循环指定列(基础数据表里的I列)
                If rng = Only(i) Then    '如果和拆分出表的名称一致，就......
                    ThisWorkbook.Sheets(Only(i)).Cells(Shtindex, 4) = rng.Offset(0, -3) '基础数据明细表的"交易金额"，写入D列
                    ThisWorkbook.Sheets(Only(i)).Cells(Shtindex, 1) = rng.Offset(0, 1)  '基础数据明细表的"摘要"，写入A列
                    Shtindex = Shtindex + 1
                End If
            Next rng

        Next i
        .AutoFilterMode = False
   End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ThisWorkbook.Save
    MsgBox "完成"

End Sub

VBA常用小代码