按多条件拆分工作表？

fengjy1976

看到网上有按条件拆分工作表后，昨晚就一直在想能不能将单条件改成按多条件，可是自己的vba基本功不够，求各位高手帮忙解决。 按条件拆分工作表1.rar (54.55 KB, 下载次数: 307)

2009-3-6 10:05 上传

点击文件名下载附件
求按多条件拆分工作表

fengjy1976

顶，沉得太快了。希望各位高手帮帮忙了。

zhaogang1960

请测试：
Sub 按照总表A列数据分类存到各新表()
    Dim arr, sht As Worksheet, temp As String, i As Long, k, t, rng As Range
    Set rng = Range("A1:E2")
    arr = Range("a3:e" & [a65536].End(xlUp).Row).Value
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr)
            temp = arr(i, 1)
            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
            Set sht = Sheets(k(i))
            If Not sht Is Nothing Then
                With sht
                    .Cells.Clear
                    rng.Copy .Range("a1") '把表头的前两行也一同复制到新工作表中
                    t(i).Copy .Range("a3")
                End With
            End If
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox "处理完毕"
End Sub

[ 本帖最后由 zhaogang1960 于 2009-3-6 21:33 编辑 ]

zhaogang1960

改进一下：
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 '减去黄色区域
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr)
            temp = arr(i, 1)
            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

jiulongpo

Sub 按照总表A列数据分类存到各新表()
On Error Resume Next
Dim Mywk As Object
Dim Mysh As Worksheet, Mysha As Worksheet
Dim Myra As Range
Dim Myraa As String
Dim Myk As Integer, Myl As Integer
Dim Myarr
Set Mysh = Worksheets("总表")
Myk = Mysh.Range("A65536").End(xlUp).Row
For k = 3 To Myk
   Myraa = Mysh.Cells(k, 1)
   Set Mysha = Worksheets(Myraa)
   'MsgBox Err.Number
   If Err.Number = 9 Then
      Worksheets.Add(After:=Worksheets(Worksheets.Count), Count:=1, Type:=xlWorksheet) _
         .Name = Myraa
      Set Mysha = Worksheets(Myraa)
      Mysh.Range("A1:E2").Copy
      Mysha.Range("A1:E2").PasteSpecial
      Err.Clear
   End If
   Myl = Mysha.Range("A65536").End(xlUp).Row + 1
   For l = 1 To 5
      Mysha.Cells(Myl, l) = Mysh.Cells(k, l)
      Mysha.Cells(Myl, l).Borders.LineStyle = xlContinuous
   Next
Next
Mysh.Activate
End Sub
按条件拆分工作表1.rar (43.4 KB, 下载次数: 518)

2009-3-6 23:03 上传

点击文件名下载附件

fengjy1976

谢谢zhaogang1960与jiulongpo 的回复，但是还差一点，我想把“一班”里面包含的“甲1”、“甲2“分别筛选，也就是说把“总表”分为“一班甲1”、“一班甲2”、“二班甲1”、“二班甲2、“三班甲1”、“三班甲2“六个工作表。

[ 本帖最后由 fengjy1976 于 2009-3-6 23:51 编辑 ]

zhaogang1960

请测试：
按条件拆分工作表1.rar (41.81 KB, 下载次数: 680)

2009-3-7 00:18 上传

点击文件名下载附件

wenwen000424

既然是多条件能否改为象排序类似的出现第一、第二、第三关键字等自由设定或者说按A列、B列自由选定？

fengjy1976

谢谢zhaogang1960与jiulongpo 你们的回复，问题已经解决，以后要向你们好好请教

liechun1983

双学到一招了