• 按部门列拆分工作表数据,生成新的工作表。

  
  

• 思路：

• 1.删除除数据源工作表外的所有工作表。

• 2.提取部门名称，也就是要新建的工作表名称。

• 3.循环新建工作表,写入对应的数据。

• 1 删除工作表

Application.DisplayAlerts = False
    For Each Sht In Worksheets
        If Sht.Name <> "总表" Then
            Sht.Delete
        End If
    Next
    Application.DisplayAlerts = True

• 2.提取部门名称，可以用去除重复的方法提取。

Paste_Image.png

 With Sheet1
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        '去除重复,提取部门名称,使用辅助列
        .Range("a1:a" & LastRow).Copy .Range("h1") '复制部门数据到H列
        .Range("h1:h" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes '去除重复值
    End With

• 3.新建工作表，然后在数据源表筛选对应的数据，复制到新表。

For i = 2 To LastRow1
            SName = .Cells(i, "H") '新建的工作表名称
            Rng.AutoFilter Field:=1, Criteria1:="" & SName '按部门筛选数据
            Set Rng1 = Rng.SpecialCells(xlCellTypeVisible) '获取可见行(筛选的数据)
            Rng.AutoFilter '关闭自动筛选
            Set Sht1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '新建工作表
            Sht1.Name = SName
            Rng1.Copy Sheets(SName).Range("a1") '复制数据到新见的工作表
   Next

• 完整的拆分工作表代码如下

Sub 拆分工作表()
    Dim LastRow As Long, LastRow1 As Long
    Dim Rng As Range, Rng1 As Range, SName As String
    Dim Sht As Worksheet, Sht1 As Worksheet
    
    Application.DisplayAlerts = False
    For Each Sht In Worksheets
        If Sht.Name <> "总表" Then
            Sht.Delete
        End If
    Next
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = False
    With Sheet1 '总表
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("a1:b" & LastRow) '数据源区域
        '去除重复,提取部门名称,使用辅助列
        .Range("a1:a" & LastRow).Copy .Range("h1") '复制部门数据到H列
        .Range("h1:h" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes '去除重复值
        LastRow1 = .Cells(Rows.Count, "H").End(xlUp).Row '获取H列最后一行行号
        For i = 2 To LastRow1
            SName = .Cells(i, "H") '新建的工作表名称
            Rng.AutoFilter Field:=1, Criteria1:="" & SName '按部门筛选数据
            Set Rng1 = Rng.SpecialCells(xlCellTypeVisible) '获取可见行(筛选的数据)
            Rng.AutoFilter '关闭自动筛选
            Set Sht1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '新建工作表
            Sht1.Name = SName
            Rng1.Copy Sheets(SName).Range("a1") '复制数据到新建的工作表
        Next
        .Range("h:h").Clear '清空辅助的部门数据
    End With
    Application.ScreenUpdating = True
End Sub

Paste_Image.png

• 至此，我们就利用前面学到的知识解决了拆分工作表的问题了。
• 拆分工作表的方法还有很多。讲真，利用一些常规的菜单操作，将之变成VBA，咋一看起来VBA太实在了。