如何根据工作表里的一列的不同内容来拆分工作表

pjypl1688888

如何根据工作表里的一列的不同内容来拆分工作表，请大神发个压缩包，谢谢

limonet

这类太多了，https://club.excelhome.net/forum ... amp;_dsign=5e3e5713

杨建营

请楼主参考。

半百

请测试。。。

ykcbf1100

总表拆分为多表，2级字典

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.29  表1拆分为多表
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set Sh = ThisWorkbook.Sheets("表1")
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> Sh.Name Then sht.Delete
   
8.     Next
   
9.     With Sh
   
10.         r = .Cells(Rows.Count, 1).End(3).Row
    
11.         arr = .[a1].Resize(r, 6)
    
12.     End With
    
13.     For i = 2 To UBound(arr)
    
14.         s = arr(i, 1)
    
15.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
16.         d(s)(i) = i
    
17.     Next
    
18.     On Error Resume Next
    
19.     For Each k In d.keys
    
20.         Sh.Copy After:=Sheets(Sheets.Count)
    
21.         Set sht = Sheets(Sheets.Count)
    
22.         m = 0
    
23.         With sht
    
24.             ReDim brr(1 To 1000, 1 To 6)
    
25.             .DrawingObjects.Delete
    
26.             .Name = k
    
27.             For Each kk In d(k).keys
    
28.                 m = m + 1
    
29.                 For j = 1 To UBound(arr)
    
30.                     brr(m, j) = arr(kk, j)
    
31.                 Next
    
32.             Next
    
33.             .[a2].Resize(m, 6) = brr
    
34.             .UsedRange.Offset(m + 1).Clear
    
35.         End With
    
36.     Next
    
37.     Sh.Activate
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    

复制代码

Qs18

Private Sub Worksheet_Deactivate()
Call qs
End Sub
Sub qs()
Dim arr, brr, i, dic, sht As Worksheet
Set dic = CreateObject("scripting.dictionary")
On Error Resume Next
With Sheet1
    arr = .Range("a1:f" & .Cells(Rows.Count, 1).End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
    For Each sht In Sheets
    m = 0
    For i = 2 To UBound(arr)
        If sht.Name <> "表1" Then
            If arr(i, 1) = sht.Name Then
                m = m + 1
                For j = 1 To UBound(arr, 2)
                    brr(m, j) = arr(i, j)
                Next
            End If
        
        End If
    Next
    sht.Range("a2").Resize(m, UBound(arr, 2)) = brr
    Next
End With
MsgBox "完成"
End Sub

Qs18

试试...........

Qs18

试试........

sdytsxd991122