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

ykcbf1100

zbxdjqls 发表于 2024-8-22 23:10
求教，模板最后一列的“含税单价”提取不到数据，代码需要怎么调整呢？

你这询价单表的结构与上一次不一样了，而且，还有二个字段是清单表中没有的。

还有，你二个表的字段名也不太一样，否则，代码可以写得更简单一点。

ykcbf1100

附件已不同，改一下吧。

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

复制代码