VBA小程序_根据指定列关键词拆分工作表（可以无视关键词排序的问题，开始之前会取消筛选，请留意）

最新推荐文章于 2024-08-19 11:42:00 发布

STR_Liang

最新推荐文章于 2024-08-19 11:42:00 发布

阅读量781

点赞数 2

分类专栏： VBA 文章标签： VBA OFFICE 微软拆分工作表 WPS

本文链接：https://blog.csdn.net/STR_Liang/article/details/107305746

版权

VBA 专栏收录该内容

62 篇文章 26 订阅

订阅专栏

Sub VBA小程序_根据指定列关键词拆分工作表()
    Rem 可以无视关键词排序的问题，开始之前会去掉筛选状态，避免错误
    Dim title As Range, split_rng As Range, title_sht_name As String, rng As Range, title_row As Long, split_rng_column As Long
    time_now = Timer()
    
    title_sht_name = ActiveSheet.Name
    ActiveSheet.AutoFilterMode = False '取消筛选
    Set title = Application.InputBox(prompt:="请选择需要保留的标题行（请选择整行）", Type:=8)
    title_row = title.Row + title.Rows.Count - 1 ' 用法同 usedrange
    
    Set split_rng = Application.InputBox(prompt:="请选择根据关键词拆分的列（请选择整列）", Type:=8)
    split_rng_column = split_rng.Column + split_rng.Columns.Count - 1 ' 用法同 usedrange
    
    Set rng = Range(Cells(title_row + 1, split_rng_column), Cells(Cells(Rows.Count, split_rng_column).End(xlUp).Row, split_rng_column))
    rng.Select
    
    Application.ScreenUpdating = False '关闭屏幕更新
    rng.Copy
    Application.Worksheets.Add
    Range("a1").PasteSpecial
    ActiveSheet.Columns(1).RemoveDuplicates Columns:=1, Header:=xlNo '删重
    
    temporary = ActiveSheet.Name ' temporary  n: 临时的，adj: 暂时的
    '复制标题/表头
    For Each sheet_name In Worksheets(temporary).UsedRange
        If sheet_name <> "" Then Worksheets.Add.Name = sheet_name
        Worksheets(title_sht_name).Range(title.Address).Copy
        ActiveSheet.PasteSpecial  '复制标题  不可以直接写title，要使用range(title.address)才行...
        Worksheets(temporary).Activate
    Next
    Application.DisplayAlerts = False '关闭屏幕提示
    Worksheets(temporary).Delete
    Application.DisplayAlerts = True '关闭屏幕提示
    
    '遍历有内容的整列，进行逐行扫描复制到对应的表格中，在这里，就不会因为没有排序关键词，导致预期之外的复制错误发生
    For Each ss In rng
        Debug.Print (ss.Value)
        Worksheets(title_sht_name).Rows(ss.Row).Copy
        Worksheets(ss.Value).Activate
        Worksheets(ss.Value).Cells(Cells(Rows.Count, split_rng_column).End(xlUp).Row + 1, 1).PasteSpecial 'Cells(Row.Count, split_rng_column).End(xlUp).Row + 1是为了获取我们作为关键词这一列的最大行号
    Next
    Application.ScreenUpdating = True '重新启用
    Application.CutCopyMode = False '取消复制内容
    MsgBox ("已完成，总计耗时：" & Application.WorksheetFunction.Round(Timer() - time_now, 2) & " 秒")
End Sub