拆分到每户户主一个工作簿每个表都要有表头与表尾

娱乐部长

sirsunny 发表于 2021-4-25 16:18
Python厉害

代码比较简洁容易理解。

h2016

留着看看学习

ykcbf1100

参与一下。。。

ykcbf1100

纯练手。。。

1. Sub ykcbf()   '//2024.3.13
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set sh = ThisWorkbook.Sheets("数据")
   
8.     bt = 6        '//标题行数
   
9.     With sh
   
10.         r = .Cells(Rows.Count, 1).End(3).Row
    
11.         arr = .UsedRange
    
12.     End With
    
13.     For i = bt + 1 To UBound(arr)
    
14.         s = CStr(arr(i, 1))
    
15.         If Val(s) Then
    
16.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
17.             d(s)(i) = i
    
18.             n = n + 1
    
19.         End If
    
20.     Next
    
21.     For Each k In d.keys
    
22.         sh.Copy
    
23.         Set wb = ActiveWorkbook
    
24.         m = 0
    
25.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
    
26.         With wb.Sheets(1)
    
27.             .Name = k
    
28.             .DrawingObjects.Delete
    
29.             .Range("A7:N" & bt + n).ClearContents
    
30.             For Each kk In d(k).keys
    
31.                 m = m + 1
    
32.                 For j = 1 To UBound(arr, 2)
    
33.                     brr(m, j) = arr(kk, j)
    
34.                 Next
    
35.                 brr(m, 2) = m
    
36.             Next
    
37.             .Cells(bt + 1, 1).Resize(m, UBound(brr, 2)) = brr
    
38.             .Range(.Cells(bt + n + 1, 1), .Cells(bt + n + 6, "M")).Copy
    
39.             .Cells(bt + n + 7, 2).Select
    
40.             ActiveSheet.Paste
    
41.             .Rows(bt + n + 1 & ":" & bt + n + 6).Delete Shift:=xlUp
    
42.             Application.CutCopyMode = False
    
43.             .Columns("A:A").Delete Shift:=xlToLeft
    
44.             .Rows(bt + n + 1 & ":" & bt + n + 1).RowHeight = 25
    
45.         End With
    
46.         wb.SaveAs p & k
    
47.         wb.Close 1
    
48.     Next
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "OK！"
    
51. End Sub
    

复制代码

h2016

户主问题学习一下，其实可以用筛选吗？