求助：一个工作根据某列拆分多个工作表，每个工作表有N个sheet

ykcbf1100

练手而已。。。

1. Sub 按客户名称拆分()   '//2024.3.23
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim t: t = Timer
   
5.     Dim d As Object, rng As Range
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set ws = ThisWorkbook
   
8.     p = ThisWorkbook.Path & ""
   
9.     For Each sht In ws.Sheets
   
10.         arr = sht.UsedRange
    
11.         c = Application.WorksheetFunction.Match("客户名称", sht.Rows(1), 0)
    
12.         For i = 2 To UBound(arr)
    
13.             s = Trim(arr(i, c))
    
14.             If s <> "" Then
    
15.                 d(s) = ""
    
16.             End If
    
17.         Next i
    
18.     Next sht
    
19.     For Each k In d.keys
    
20.         ws.Sheets.Copy
    
21.         Set wb = ActiveWorkbook
    
22.         For Each sht In Sheets
    
23.             With sht
    
24.                 arr = .UsedRange
    
25.                 c = Application.WorksheetFunction.Match("客户名称", sht.Rows(1), 0)
    
26.                 .DrawingObjects.Delete
    
27.                 For i = 2 To UBound(arr)
    
28.                     If Trim(arr(i, c)) <> k Then
    
29.                         If rng Is Nothing Then
    
30.                             Set rng = .Rows(i)
    
31.                         Else
    
32.                             Set rng = Union(rng, .Rows(i))
    
33.                         End If
    
34.                     End If
    
35.                 Next i
    
36.                 If Not rng Is Nothing Then rng.Delete
    
37.                 Set rng = Nothing
    
38.             End With
    
39.         Next
    
40.         wb.SaveAs p & k
    
41.         wb.Close
    
42.     Next k
    
43.     Application.ScreenUpdating = True
    
44.     Application.DisplayAlerts = True
    
45.     MsgBox "拆分完毕，共用时： " & Format(Timer - t, "0.000秒"), , "提示"
    
46. End Sub
    

复制代码