求将总表里面按第一列部门分成若干工作表，以部门命名

missd

求将总表按第一列部门分成若干工作表，以部门命名，并且将总表里部门对应E列收款人的小sheet表分别复制到分成的若干工作表里，类似于附件格式。

lsc900707

真正的要求是拆分独立工作簿吧。这个拆分有点意思。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Application.ScreenUpdating = True
   
7.   Application.DisplayAlerts = False
   
8.   With Worksheets("汇")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a1:l" & r)
    
11.     For i = 4 To UBound(arr)
    
12.       If Not d.exists(arr(i, 1)) Then
    
13.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
14.         Set d(arr(i, 1))(2) = CreateObject("scripting.dictionary")
    
15.       End If
    
16.       If Not d(arr(i, 1)).exists(1) Then
    
17.         Set d(arr(i, 1))(1) = .Range("a1:l3")
    
18.       End If
    
19.       Set d(arr(i, 1))(1) = Union(d(arr(i, 1))(1), .Cells(i, 1).Resize(1, 12))
    
20.       d(arr(i, 1))(2)(arr(i, 5)) = ""
    
21.     Next
    
22.   End With
    
23.   For Each aa In d.keys
    
24.     Application.SheetsInNewWorkbook = 1
    
25.     Set wb = Workbooks.Add
    
26.     With wb
    
27.       With .Worksheets(1)
    
28.         .Name = "汇"
    
29.         d(aa)(1).Copy .Range("a1")
    
30.       End With
    
31.       On Error Resume Next
    
32.       ThisWorkbook.Worksheets(d(aa)(2).keys).Copy after:=.Worksheets(Worksheets.Count)
    
33.       On Error GoTo 0
    
34.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa, FileFormat:=xlExcel8
    
35.       .Close False
    
36.     End With
    
37.   Next
    
38.       
    
39. End Sub
    

复制代码

chxw68

版主说得对，这个问题有点意思。