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

nnsea

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