1、拆分工作表（按照客户指定表*指定列）

最新推荐文章于 2024-09-07 23:35:47 发布

年景@

最新推荐文章于 2024-09-07 23:35:47 发布

阅读量112

点赞数 2

分类专栏： VBA 文章标签：汇编

本文链接：https://blog.csdn.net/weixin_73737526/article/details/138794745

版权

VBA 专栏收录该内容

6 篇文章 0 订阅

订阅专栏

Sub 拆分工作表() '按照客户指定表指定列拆分
    Dim sht As Worksheet
    Dim str As String
    Dim i, j, k As Integer
    Dim l
    Dim irow, icolumn As Integer
    '由用户指定拆分哪张工作表
    str = InputBox("请问要拆分哪张工作表？请输入工作表的标签名：")
    '判断该表是否存在
    For Each sht In Sheets
        If sht.Name = str Then
            k = 1
        End If
    Next
    If k = 0 Then
        MsgBox "该工作表不存在，请输入正确的标签名！"
        Exit Sub
    End If
    '获取需要进行拆分的工作表最后一行数据的行号及最后一列的列号
    irow = Sheets(str).Range("a65536").End(xlUp).Row
    icolumn = Sheets(str).Range("iv1").End(xlToLeft).Column
    '由用户指定根据第几列进行数据拆分
    l = InputBox("请问需要根据第几列进行数据拆分？")
    '如果l不是数字、小于1或者大于icolumn，弹出提示框并中止过程
    If IsNumeric(l) = False Or l < 1 Or l > icolumn Then
        MsgBox "请输入正确的数字"
        Exit Sub
    End If
    '将l转变为数字类型
    l = Val(l)
    '删除非指定工作表之外的其他所有工作表
    Application.DisplayAlerts = False
    For Each sht In Sheets
        If sht.Name <> str Then
            sht.Delete
        End If
    Next
    Application.DisplayAlerts = True
    '根据用户指定的列新建工作表并确保表名不重复
    For i = 2 To irow
        k = 0
        For Each sht In Sheets
            If Sheets(str).Cells(i, l) = sht.Name Then
                k = 1
            End If
        Next
        If k = 0 Then
            Sheets.Add after:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = Sheets(str).Cells(i, l)
        End If
    Next
    '根据用户指定的列进行筛选和复制
    For j = 2 To Sheets.Count
        Sheets(str).Cells(1, 1).Resize(irow, icolumn).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
        Sheets(str).Cells(1, 1).Resize(irow, icolumn).Copy Sheets(j).Range("a1")
    Next
    Sheets(str).Cells(1, 1).Resize(irow, icolumn).AutoFilter
    '所有操作完成后回到"数据"工作表，并弹出提示框
    Sheets(str).Select
    MsgBox "已按照第" & l & "列对“" & str & "”工作表拆分完成！"
End Sub