修改原有代码，实现现在模板的拆分

ykcbf1100

老丢710 发表于 2024-5-20 13:44
您抽空给改一下订单号汇总行吗

我先看看。。

ykcbf1100

老丢710 发表于 2024-5-20 13:44
您抽空给改一下订单号汇总行吗

代码更新：1、质保金日期据实写入；2、费率修正。
订单号重复合并问题，我觉得还是修改源数据为宜，现在的代码已经很复杂了，到时候维护起来麻烦的。

ykcbf1100

代码更新。。。

1. Sub ykcbf()  '//2024.5.20
   
2.     Dim arr, d, zj(), sum()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     tod = Date
   
8.     Set ws = ThisWorkbook
   
9.     Set sh = ws.Sheets("供应明细表")
   
10.     bt = 3: col = 6
    
11.     For Each sht In ws.Sheets
    
12.         If sht.Name <> sh.Name And sht.Name <> "数据" Then sht.Delete
    
13.     Next
    
14.     arr = ws.Sheets("数据").UsedRange
    
15.     For i = bt + 1 To UBound(arr)
    
16.         s = arr(i, col): ss = arr(i, 2)
    
17.         If s <> Empty Then
    
18.             If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
    
19.             If Not d(s).Exists(ss) Then Set d(s)(ss) = CreateObject("scripting.dictionary")
    
20.             d(s)(ss)(i) = i
    
21.         End If
    
22.     Next i
    
23.     b = [{2,7,5,4}]: bb = [{4,5,6,9,10}]
    
24.     For Each k In d.keys
    
25.         ReDim zj(1 To 5)
    
26.         sh.Copy after:=ws.Sheets(ws.Sheets.Count)
    
27.         Set sht = ws.Sheets(ws.Sheets.Count)
    
28.         ReDim brr(1 To 30, 1 To 10)
    
29.         m = 0: lc = 26
    
30.         With sht
    
31.             n = 0
    
32.             .Name = k
    
33.             .[a2] = "供应明细表--" & .Name
    
34.             For Each kk In d(k).keys
    
35.                 ReDim sum(1 To 5)
    
36.                 For Each kkk In d(k)(kk).keys
    
37.                     m = m + 1: n = n + 1
    
38.                     brr(m, 1) = n
    
39.                     For j = 1 To UBound(b)
    
40.                         brr(m, j + 1) = arr(kkk, b(j))
    
41.                     Next
    
42.                     brr(m, 6) = Application.WorksheetFunction.Round(brr(m, 5) * 0.05, 2)
    
43.                     brr(m, 7) = DateAdd("yyyy", 1, tod)
    
44.                     brr(m, 8) = 0.05
    
45.                     brr(m, 9) = Application.WorksheetFunction.Round(brr(m, 4) * Val(brr(m, 8)), 2)
    
46.                     brr(m, 10) = Application.WorksheetFunction.Round(brr(m, 9) * 1.06, 2)
    
47.                     For x = 1 To 5
    
48.                         sum(x) = sum(x) + brr(m, bb(x))
    
49.                     Next
    
50.                 Next
    
51.                 m = m + 1
    
52.                 brr(m, 2) = kk & " 小计"
    
53.                 For x = 1 To 5
    
54.                     brr(m, bb(x)) = sum(x)
    
55.                     zj(x) = zj(x) + sum(x)
    
56.                 Next
    
57.             Next
    
58.             m = m + 1
    
59.             brr(m, 2) = "总计"
    
60.             For x = 1 To 5
    
61.                 brr(m, bb(x)) = zj(x)
    
62.             Next
    
63.             k = lc - m
    
64.             If k > 0 Then .Rows(6 & ":" & 5 + k).Delete
    
65.             If k < 0 Then
    
66.                 For i = 1 To m - lc
    
67.                     .Cells(10 + i, 1).EntireRow.Insert
    
68.                 Next i
    
69.             End If
    
70.             .[a5].Resize(m, 10) = brr
    
71.             For i = 5 To 5 + m - 1
    
72.                 .Cells(i, 1).Resize(1, 10).ShrinkToFit = True
    
73.                 If Val(.Cells(i, 1)) = 0 Then
    
74.                     .Cells(i, 1).Resize(1, 10).Font.Bold = True
    
75.                     .Cells(i, 1).Resize(1, 10).Font.Name = "黑体"
    
76.                 End If
    
77.             Next
    
78.         End With
    
79.     Next k
    
80.     ws.Sheets("数据").Activate
    
81.     Set d = Nothing
    
82.     Application.DisplayAlerts = True
    
83.     Application.ScreenUpdating = True
    
84.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
85. End Sub
    
86. 
    

复制代码

老丢710

ykcbf1100 发表于 2024-5-20 14:56
代码更新：1、质保金日期据实写入；2、费率修正。
订单号重复合并问题，我觉得还是修改源数据为宜，现在 ...

源数据需要分别生成带发票号的和不带发票号的表格，如果合并订单号，源数据就不能直实反映对应的发票号了，所以只能在拆分中汇总，劳驾您给改一下代码，实现拆分后显示汇总的订单号。

老丢710

ykcbf1100 发表于 2024-5-20 14:56
代码更新：1、质保金日期据实写入；2、费率修正。
订单号重复合并问题，我觉得还是修改源数据为宜，现在 ...

服务费计算结果依然不对，两个模板的源数据均来至源数据，多个发票号对应采购订单号是有其他用途的，所以只能在拆分生成新表时进行汇总，劳烦抽空再改一下代码行吗？

ykcbf1100

老丢710 发表于 2024-5-20 15:38
服务费计算结果依然不对，两个模板的源数据均来至源数据，多个发票号对应采购订单号是有其他用途的，所以 ...

服务费计算，请详细说一下，如何不对？具体应该是如何计算的。

老丢710

不含税服务费等于不含税供应额乘以服务费率（5%），表中5%参与计算时取值是5，而不是0.05，单元格内数据格式的问题

ykcbf1100

老丢710 发表于 2024-5-21 08:54
不含税服务费等于不含税供应额乘以服务费率（5%），表中5%参与计算时取值是5，而不是0.05，单元格内数据格 ...

这个我已经改了。

老丢710

ykcbf1100 发表于 2024-5-21 09:54
这个我已经改了。

我下载的模版3还是计算错误，不知道什么原因，这个问题好解决，麻烦费点功夫解决一下拆分后订单号合并汇总的问题。拜托

ykcbf1100

老丢710 发表于 2024-5-21 12:54
我下载的模版3还是计算错误，不知道什么原因，这个问题好解决，麻烦费点功夫解决一下拆分后订单号合并汇 ...

订单号合并暂时解决不了。