VBA应用

01 工作表

按指定列拆分为工作表或工作簿(选择表头和表尾)

关于Excel 和 VBA

在Excel_VBA基础的第6、7、8章，有Range单元格、WorkSheet工作表、WorkBook工作簿对象。其实VBA的过程，大多都是通过用代码操作Excel这个Application内的各种对象\按照我们的制定的逻辑自动运算的过程。操作对象非常重要。

一个VBA解决工作的示例：工作表拆分—要求按照制定的列内容，把一个样本表，拆分成多个工作表或工作簿

运行视频：

源码下载：

描述：

一个日访客的日接待登记本，当月结束后，要给接待人员按照接待量结算工资。需要让他们每个人确认签字！电子档是按照月登记在一张表内，如何拆分？

需求分析：

1、按照接待人员列(为了代码的使用范围更广泛，我们用自定义列)拆分；
2、便于每个人签字，要有表头行和表尾行；（同样自定义是可选择行）；
3、是拆分成一个工作簿里的工作表，还是多个工作簿，可供选择。

VBA实现过程：

1、三个自定义，指定列、指定表头、指定表尾，用Application.InputBox和用户交互，让她/他来自定义选择；
2、是拆分工作簿还是工作表，用MsgBox和用户交互，根据用户在弹窗上对不同选项的选择，来决定是拆分工作簿还是工作表；
3、拆分成工作表是在保存代码的当前工作簿内，拆分成工作簿，路径是当前工作簿的相同路径，用ThisWorkbook.Path属性获取所在路径；
4、主程序逻辑实现过程：

①:先对指定的列内的单元格内容，用一个集合去重掉重复值，在对这个不重复的数组循环遍历；
②:循环中，新建一个工作簿\工作表，用单元格内容命名；
③:循环中，调用Excel工作表的内置的筛选方法.AutoFilter Field:="筛选列", Criteria1:="筛选值"，复制筛选出的可见内容；
④:粘贴到新建的工作簿\工作表中。

5、拆分完成！

示例代码

复制成功!


Sub 工作表拆分()
    '----------------------------------------------------
     '自定义各数据类型
    Dim Splitcol, Headrow, Endrow, rng As Range
    Dim Colnum As Integer, Head_count As Byte, End_count As Byte, Arr, Lastrow, i, Shtindex, Only As New Collection
    Dim Msg, New_wk

    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
    '-----------------------------------------------------
    '设置标题行和尾部
    Set Headrow = Application.InputBox("选择整个行区域\或行所在区域的任意单元格均可", "选择标题行", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    Head_count = Headrow.Rows.Count
    If Head_count >= Splitcol.Parent.UsedRange.Rows.Count Then Exit Sub

    Set Endrow = Application.InputBox("选择整个行区域\或行所在区域的任意单元格均可", "选择尾行", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    End_count = Endrow.Rows.Count
    If End_count >= Splitcol.Parent.UsedRange.Rows.Count Then Exit Sub

    On Error GoTo 0

    Msg = MsgBox("选择是―拆分为工作表" & Chr(10) & "选择否―拆分为工作薄", vbYesNo, "自定义拆分类型")

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

        '-------------------------------------------------
        '对需要拆分的条件列的值剔除重复值，利用Colection有序集合的成员不能存在重复内容的作用
        Arr = .Range(.Cells(Head_count + 1, Colnum), .Cells(Lastrow - End_count, Colnum))
        On Error Resume Next
        For i = 1 To Lastrow - Head_count
            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  '关闭显示特定的警告和消息，删除已经存在相同名字的工作表时，不弹出消息

    If Msg = vbYes Then   '判断不同的拆分类型
        '拆分为工作表
        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

        '------------------------------------------------
        '利用筛选、复制可见内容的方式，分别将表格的内容拆分到各分表中
        .AutoFilterMode = False
        For i = 1 To Only.Count
            .Range(.Cells(Head_count, 1), .Cells(Lastrow - End_count, Colnum)).AutoFilter Field:=Colnum, Criteria1:=Only(i)
            .Range(.Cells(Lastrow - End_count + 1, 1), .Cells(Lastrow, Colnum)).EntireRow.Hidden = False
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy

            ThisWorkbook.Sheets(Only(i)).Paste
            ThisWorkbook.Sheets(Only(i)).Cells.EntireColumn.AutoFit

        Next i
        .AutoFilterMode = False

      Else
      '拆分为工作薄
        .AutoFilterMode = False
        For i = 1 To Only.Count
            Err.Clear
            Set New_wk = Workbooks.Add
            New_wk.SaveAs Filename:=ThisWorkbook.Path & "\" & Only(i)

             .Range(.Cells(Head_count, 1), .Cells(Lastrow, Colnum)).AutoFilter Field:=Colnum, Criteria1:=Only(i)
             .Range(.Cells(Lastrow - End_count + 1, 1), .Cells(Lastrow, Colnum)).EntireRow.Hidden = False
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Workbooks(Only(i) & ".xlsx").Sheets(1).Range("a1")

            Workbooks(Only(i) & ".xlsx").Sheets(1).Cells.EntireColumn.AutoFit
            Workbooks(Only(i) & ".xlsx").Save
            Workbooks(Only(i) & ".xlsx").Close

        Next i
        .AutoFilterMode = False
      End If


   End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ThisWorkbook.Save
    MsgBox "拆分完毕"

End Sub

VBA常用小代码