按多条件拆分工作表？

fengjy1976 · 发表于 2009-3-6 10:05

看到网上有按条件拆分工作表后，昨晚就一直在想能不能将单条件改成按多条件，可是自己的vba基本功不够，求各位高手帮忙解决。

fengjy1976 · 发表于 2009-3-6 20:20

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

zhaogang1960 · 发表于 2009-3-6 21:24

请测试：
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 · 发表于 2009-3-6 22:30

改进一下：
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 · 发表于 2009-3-6 23:03

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)

fengjy1976 · 发表于 2009-3-6 23:07

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

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

zhaogang1960 · 发表于 2009-3-7 00:18

请测试：

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

wenwen000424 · 发表于 2009-3-7 07:56

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

fengjy1976 · 发表于 2009-3-7 18:05

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

liechun1983 · 发表于 2009-3-7 22:12

双学到一招了

		自动登录	找回密码
密码			免费注册

[求助] 按多条件拆分工作表？

回复 7楼 fengjy1976 的帖子