工作中的重复工作-筛选拆分后按指定格式输出拆分表格

zbxdjqls

换了新工作岗位，感觉每天都被表格筛选复制粘贴淹没了，求助解决筛选拆分后按指定格式输出拆分表格。
~~为了尽量还原工作环境，放一张总表

按照M列“建议厂商”进行筛选后，指定格式输出文件“总表_XX”
以筛选“合田”为例，输出结果如下：

1、拆分表中的G2=“合田”
2、拆分表中的M2=总表中的W1
3、拆分表中的“含税单价”=总表中的“拟签约含税单价”
4、拆分表中的“含税金额”=“含税单价”*“数量”
5、拆分表中的“合计”一行，求和“含税金额”，并做大写。
6、拆分表中的“来源”一行C11=总表中的A1"2024Y-175护板2、磨耗板等物资委外加工（询比价采购）工作报表"
7、拆分表中其他位置以示例固定数据。

求大神解救我脱离苦海~

liulang0808

按模板拆分，论坛中的案例不少，楼主检索参考下

ykcbf1100

总表拆分为多工作簿

ykcbf1100

总表拆分

1. Sub ykcbf()      '//2024.8.21    总表拆分
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim tm: tm = Timer
   
5.     Dim arr, brr, b, d
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set fso = CreateObject("Scripting.FileSystemObject")
   
8.     p = ThisWorkbook.Path & ""
   
9.     Set sh = ThisWorkbook.Sheets("清单")
   
10.     c = 13     '//拆分列号
    
11.     With sh
    
12.         r = .Cells(.Rows.Count, c).End(xlUp).Row
    
13.         arr = .Range("a1:y" & r)
    
14.     End With
    
15.     For i = 3 To UBound(arr)
    
16.         s = arr(i, c)
    
17.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
18.         d(s)(i) = i
    
19.     Next
    
20.     On Error Resume Next
    
21.     fn = "总表拆分表_"
    
22.     For Each k In d.keys
    
23.         m = 0
    
24.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
25.         Sheets("模板").Copy
    
26.         Set wb = ActiveWorkbook
    
27.         With wb.Sheets(1)
    
28.             .[m2] = CDate(Date)
    
29.             .DrawingObjects.Delete
    
30.             For Each kk In d(k).keys
    
31.                 m = m + 1
    
32.                 brr(m, 1) = m
    
33.                 For j = 2 To 12
    
34.                     brr(m, j) = arr(kk, j)
    
35.                 Next
    
36.                 brr(m, 13) = arr(kk, 15)
    
37.                 brr(m, 14) = arr(kk, 16)
    
38.                 brr(m, 15) = arr(kk, 18)
    
39.                 brr(m, 16) = arr(kk, 23)
    
40.                 brr(m, 17) = arr(kk, 24)
    
41.             Next
    
42.             If m > 6 Then
    
43.                 For i = 1 To m - 6
    
44.                     Cells(5 + i, 1).EntireRow.Insert
    
45.                 Next i
    
46.             End If
    
47.             .[a4].Resize(m, 17) = brr
    
48.             r1 = IIf(m <= 6, 10, 4 + m)
    
49.             .Cells(r1, "n") = Application.Sum(.Cells(4, "q").Resize(m))
    
50.             rmb = .Cells(r1, "n").Value
    
51.             .Cells(r1, "d").Value = RmbDx(rmb)
    
52.         End With
    
53.         wb.SaveAs p & fn & k
    
54.         wb.Close
    
55.     Next
    
56.     Set d = Nothing
    
57.     Application.ScreenUpdating = True
    
58.     MsgBox "拆分完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
59. End Sub

复制代码

zbxdjqls

ykcbf1100 发表于 2024-8-21 08:41
总表拆分

谢谢，万分感谢！

zbxdjqls

ykcbf1100 发表于 2024-8-21 08:39
总表拆分为多工作簿

谢谢！万分感谢！好多项工作迎刃而解，一整天上班都心情爽爽的

ykcbf1100

zbxdjqls 发表于 2024-8-21 23:49
谢谢！万分感谢！好多项工作迎刃而解，一整天上班都心情爽爽的

开心就好。。。

zbxdjqls

ykcbf1100 发表于 2024-8-21 08:41
总表拆分

老师你好，我参照借用这段编码时发现，brr(m, 18) 及之后列无法赋值，请问需要怎么调整呢？

ykcbf1100

zbxdjqls 发表于 2024-8-22 21:59
老师你好，我参照借用这段编码时发现，brr(m, 18) 及之后列无法赋值，请问需要怎么调整呢？

有些地方得改的，每个表的情况不一样。

zbxdjqls

ykcbf1100 发表于 2024-8-22 22:07
有些地方得改的，每个表的情况不一样。

求教，模板最后一列的“含税单价”提取不到数据，代码需要怎么调整呢？