搜索
查看: 135|回复: 0

根据A列出现内容拆分成不同表格

[复制链接]

977

主题

1093

帖子

1万

积分

管理员

Rank: 9Rank: 9Rank: 9

积分
15931
发表于 2024-2-12 21:15:29 | 显示全部楼层 |阅读模式

Sub 拆分()
    Dim wsSummary As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim wsNew As Worksheet
    Dim dict As Object
    Dim lastRow As Long
    Dim key As Variant
    Dim filterRange As Range
    Dim copyRange As Range
    Dim startRow As Long
      
    ' 设置原始数据工作表
    Set wsSummary = ThisWorkbook.Sheets("Sheet1") ' 假设数据在 "Sheet1" 工作表上
      
    ' 获取 A 列的最后一行
    lastRow = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row
      
    ' 设置要遍历的范围(A列)
    Set rng = wsSummary.Range("A2:A" & lastRow) ' 假设第一行是标题行,从第二行开始数据
      
    ' 创建一个字典以存储不重复的值
    Set dict = CreateObject("Scripting.Dictionary")
      
    ' 遍历 A 列并将不重复的值添加到字典中
    For Each cell In rng
        If Not dict.exists(cell.Value) Then
            dict.Add cell.Value, Nothing
        End If
    Next cell
      
    ' 关闭屏幕更新以提高性能
    Application.ScreenUpdating = False
      
    ' 对于字典中的每个键,创建一个新的工作表并复制相关的行(不包括标题)
    For Each key In dict.keys
        ' 创建新的工作表
        Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsNew.Name = key & "_明细" ' 以"_明细"结尾避免命名冲突
         
        ' 复制标题行到新工作表
        wsSummary.Rows(1).Copy Destination:=wsNew.Rows(1)
         
        ' 设置筛选范围(包括标题行)
        Set filterRange = wsSummary.Range("A1:A" & lastRow)
         
        ' 应用筛选
        filterRange.AutoFilter Field:=1, Criteria1:=key
         
        ' 找到筛选后的数据范围的起始行(标题行之后的第一行)
        startRow = IIf(Application.WorksheetFunction.Subtotal(103, filterRange) > 1, 2, 1)
         
        ' 设置要复制的范围(排除标题行)
        Set copyRange = wsSummary.Range("A" & startRow & ":A" & lastRow).SpecialCells(xlCellTypeVisible)
        Set copyRange = wsSummary.Range(wsSummary.Cells(startRow, 1), wsSummary.Cells(lastRow, wsSummary.Cells(1, wsSummary.Columns.Count).End(xlToLeft).Column)).SpecialCells(xlCellTypeVisible)
         
        ' 如果筛选后有可见行,则复制可见行到新工作表的下一行(第二行开始)
        If copyRange.Rows.Count > 0 Then
            copyRange.Copy Destination:=wsNew.Cells(2, 1)
        End If
         
        ' 清除筛选
        wsSummary.AutoFilterMode = False
    Next key
      
    ' 重新打开屏幕更新
    Application.ScreenUpdating = True
      
    ' 清理对象
    Set wsSummary = Nothing
    Set rng = Nothing
    Set cell = Nothing
    Set wsNew = Nothing
    Set dict = Nothing
      
    ' 提示成功信息
    MsgBox "数据已成功拆分到不同的工作表中!"
End Sub
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

表格智创网

网站简介:表格智创网,是一家以表格设计和技能分享的专业社区,由会计帮帮网投资建设,尽专业,助提高专业技能。

表格智创网欢迎您!

联系我们

  • 工作时间:早上9:00-16:00
  • 客服电话:18668755857
  • 本站网址:www.excelwps.com
  • 淘宝店址:kjbbw.taobao.com

Powered by Discuz! X3.4 © 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表