拆分工作表到工作表

使用宏

------------------------拆分成工作表-----------------------

Sub 按照总表A列数据分类存到各新表()
    Dim arr, sht As Worksheet, temp As String, i As Long, k, t, rng1 As Range, rng2 As Range
    Set rng1 = Range("A1:E2")
    Set rng2 = Range("A40:E42")
    arr = Range("a3:e" & [a65536].End(xlUp).Row - 2).Value '减去区域
    MsgBox ([IV1].End(xlToLeft).conlumn)
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr)
            temp = arr(i, 1) & arr(i, 2)
            If temp <> "" Then
                If Not .exists(temp) Then
                    .Add temp, Range("a" & i + 2).Resize(1, 5)
                Else
                    Set .Item(temp) = Union(.Item(temp), Range("a" & i + 2).Resize(1, 5))
                End If
            End If
        Next i
        k = .keys
        t = .Items

        On Error Resume Next
        For i = 0 To .Count - 1
            If Len(Sheets(k(i)).Name) > 0 Then '判断工作表存在
                If Err.Number = 9 Then '如果不存在则添加
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = k(i)
                    Sheets("总表").Activate
                End If
            End If
            With Sheets(k(i))
                .Cells.Clear
                rng1.Copy .Range("a1") '把表头的前两行也一同复制到新工作表中
                t(i).Copy .Range("a3")
                rng2.Copy .Range("a65536").End(3).Offset(1) '末尾区域复制到新拆分的每个工作表中
            End With
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox "处理完毕"
End Sub