每日记录生成拆分汇总VBA求助

Migrantworkers

1：生成记录带抬头，固定列宽行高，生成数据为区域A:L；

2：当K列跟进记录有数据/文字的时候，整行提取到生成记录中，按日期排序下去；

3：当生成记录后，清除B列时间跟K列跟进记录，或者单独代码清除；

4：可按C列省份拆分工作簿如：广东，北京，上海等；

5：如果能点击E列公司名称就能弹窗录入生成更好；

Migrantworkers

麻烦各位大神有空帮忙写写，感激

Migrantworkers

有没有大神，，路过，，搭救下孩子

Migrantworkers

真的没有大神抬一手吗

hzruziniu

记录生成拆分汇总.rar (27.38 KB, 下载次数: 42)

2021-10-20 16:37 上传

点击文件名下载附件

1. Sub 生成记录()
   
2.     Dim arr, brr(), r&, i&, n&
   
3.     arr = Sheets("测试总表").[a1].CurrentRegion
   
4.     ReDim brr(1 To 1000, 1 To 12)
   
5.     For i = 2 To UBound(arr)
   
6.         If arr(i, 11) <> "" Then
   
7.             n = n + 1
   
8.             brr(n, 1) = i
   
9.             For j = 2 To 12
   
10.                 brr(n, j) = arr(i, j)
    
11.             Next
    
12.         End If
    
13.     Next
    
14.     If n > 0 Then
    
15.         r = Range("a65536").End(3).Row
    
16.      '   Range("b2:b" & r) = ""
    
17.         Range("k2:k" & r) = ""
    
18.         With Sheets("生成记录")
    
19.            .Cells.Clear
    
20.             Rows("1:2").Copy                     '复制测试总表第1行至第2行
    
21.             .Rows("1:2").PasteSpecial xlPasteAll '值与格式一起粘贴到新建表的1至4行
    
22.             .Rows(1).PasteSpecial xlPasteColumnWidths '选择性粘贴列宽
    
23.             .Columns(13).Delete
    
24.             .Rows("2").Copy
    
25.             .Rows(3 & ":" & 50).PasteSpecial xlPasteFormats   '选择性粘贴第2行格式
    
26.             .Range("a2").Resize(n, 12) = brr
    
27.             .Range("a1").Resize(n + 1, 12).Borders.LineStyle = xlContinuous    ' 1添加整体边框线实线'xlContinuous 1
    
28. 
    
29.         End With
    
30.     End If
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    
34. Sub 折分工作表()
    
35.     Dim arr, brr(), d, k, r&, i&, n&, j&
    
36.     Set d = CreateObject("scripting.dictionary")
    
37.     Application.ScreenUpdating = False '关闭屏幕刷新
    
38.     Application.DisplayAlerts = False
    
39.     arr = Sheets("测试总表").[a1].CurrentRegion
    
40.     For i = 2 To UBound(arr)
    
41.         d(arr(i, 3)) = ""
    
42.     Next
    
43.     k = d.keys
    
44.     删除分表
    
45.     For Each k In d.keys
    
46.         ReDim brr(1 To 5000, 1 To 13)
    
47.         For i = 2 To UBound(arr)
    
48.             If arr(i, 3) = k Then
    
49.                 n = n + 1
    
50.                 brr(n, 1) = n
    
51.                 For j = 2 To 13
    
52.                     brr(n, j) = arr(i, j)
    
53.                 Next
    
54.             End If
    
55.         Next
    
56.         Sheets.Add After:=Sheets(Sheets.Count)
    
57.         Sheets(Sheets.Count).Name = k
    
58.         With ActiveSheet
    
59.             Sheets("测试总表").Rows(1).Copy     '复制测试表第1行
    
60.             .Rows(1).PasteSpecial xlPasteAll    '值与格式一起粘贴到新建表的1行
    
61.             .Rows(1).PasteSpecial xlPasteColumnWidths '选择性粘贴列宽
    
62.             .Range("a2").Resize(n, 13) = brr          '正表赋值
    
63.             Sheets("测试总表").Rows(2 & ":" & n + 1).Copy
    
64.             .Rows(2 & ":" & n + 1).PasteSpecial xlPasteFormats   '选择性粘贴第2行格式
    
65.             .Range("a2").Resize(n, 13).Borders.LineStyle = xlContinuous
    
66.         End With
    
67.         n = 0
    
68.     Next
    
69.     Application.ScreenUpdating = True '关闭屏幕刷新
    
70.     Application.DisplayAlerts = True
    
71.      MsgBox "OK！"
    
72. End Sub
    
73. 
    
74. Sub 删除分表()
    
75.     Application.DisplayAlerts = False
    
76.     For Each Sh In Sheets
    
77.         If Sh.Name <> "测试总表" And Sh.Name <> "生成记录" And Sh.Name <> "参数设置" Then Sh.Delete
    
78.     Next
    
79.     Application.DisplayAlerts = True
    
80. End Sub
    

复制代码

Migrantworkers

hzruziniu 发表于 2021-10-20 16:39

感谢，立马试试

Migrantworkers

hzruziniu 发表于 2021-10-20 16:39

代码目前是可以用，但好像我漏了个条件，就是生成记录公司名称重复可录入，能再帮忙改改吗，

Migrantworkers

hzruziniu 发表于 2021-10-20 16:39

还有空吗，希望帮忙在解决下