求助按模板拆分明细，并对明细分类汇总的代码

ykcbf1100

老丢710 发表于 2024-5-11 15:17
ykcbf1100大神，换了个模板，能帮忙修改一下代码吗？

我出去爬了二天山，今天才打开电脑。我看看。

老丢710

ykcbf1100 发表于 2024-5-13 09:47
我出去爬了二天山，今天才打开电脑。我看看。

感谢ykcbf1100，感恩论坛。

ykcbf1100

老丢710 发表于 2024-5-11 15:17
ykcbf1100大神，换了个模板，能帮忙修改一下代码吗？

你这个我刚才看了，按用料单位为主、供应商为辅拆分不行，明细出不来。应该反过来，按用供应商为主、用料单位为辅拆分才能往下操作。

老丢710

ykcbf1100 发表于 2024-5-13 10:08
你这个我刚才看了，按用料单位为主、供应商为辅拆分不行，明细出不来。应该反过来，按用供应商为主、用料 ...

这个模板要求是按用料单位拆分表单，如果在取值上有问题，是不是可以将用料单位和供应商在数据表中的位置调整一下，是不是可以实现，然后后面加上计算。

ykcbf1100

老丢710 发表于 2024-5-13 10:36
这个模板要求是按用料单位拆分表单，如果在取值上有问题，是不是可以将用料单位和供应商在数据表中的位置 ...

按你现在的数据表结构，你无法拆分的，因为供应商少，用料单位多。按用料单位拆分的话，每个用料单位只有一个供应商。你摸拟的表数据，北机段在数据表中只有一个记录，无法与你现在的数据匹配的。

老丢710

ykcbf1100 发表于 2024-5-13 10:47
按你现在的数据表结构，你无法拆分的，因为供应商少，用料单位多。按用料单位拆分的话，每个用料单位只有 ...

我把使用单位只留了4个，您看这个能做吗

ykcbf1100

老丢710 发表于 2024-5-13 11:08
我把使用单位只留了4个，您看这个能做吗

我看一下先。

ykcbf1100

老丢710 发表于 2024-5-13 11:08
我把使用单位只留了4个，您看这个能做吗

改好了，大部分重写了。

ykcbf1100

按用料单位和供应商拆分。

1. Sub ykcbf()  '//2024.5.13
   
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.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("供应明细表")
   
9.     bt = 3: col = 6
   
10.     For Each sht In ws.Sheets
    
11.         If sht.Name <> sh.Name And sht.Name <> "说明" And sht.Name <> "数据" Then sht.Delete
    
12.     Next
    
13.     arr = ws.Sheets("数据").UsedRange
    
14.     For i = bt + 1 To UBound(arr)
    
15.         s = arr(i, col): ss = arr(i, 2)
    
16.         If s <> Empty Then
    
17.             If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
    
18.             If Not d(s).Exists(ss) Then Set d(s)(ss) = CreateObject("scripting.dictionary")
    
19.             d(s)(ss)(i) = i
    
20.         End If
    
21.     Next i
    
22.     b = [{2,7,4,5}]: bb = [{4,5,6,9,10}]
    
23.     For Each k In d.keys
    
24.         ReDim zj(1 To 5)
    
25.         sh.Copy after:=ws.Sheets(ws.Sheets.Count)
    
26.         Set sht = ws.Sheets(ws.Sheets.Count)
    
27.         ReDim brr(1 To 30, 1 To 10)
    
28.         m = 0: lc = 26
    
29.         With sht
    
30.             n = 0
    
31.             .Name = k
    
32.             .[a2] = "供应明细表--" & .Name
    
33.             For Each kk In d(k).keys
    
34.                 ReDim sum(1 To 5)
    
35.                 For Each kkk In d(k)(kk).keys
    
36.                     m = m + 1: n = n + 1
    
37.                     brr(m, 1) = n
    
38.                     For j = 1 To UBound(b)
    
39.                         brr(m, j + 1) = arr(kkk, b(j))
    
40.                     Next
    
41.                     brr(m, 6) = Application.WorksheetFunction.Round(brr(m, 5) * 0.05, 2)
    
42.                     brr(m, 7) = "当前日期加一年"
    
43.                     brr(m, 8) = "5%"
    
44.                     brr(m, 9) = Application.WorksheetFunction.Round(brr(m, 4) * Val(brr(m, 8)), 2)
    
45.                     brr(m, 10) = Application.WorksheetFunction.Round(brr(m, 9) * 1.06, 2)
    
46.                     For x = 1 To 5
    
47.                         sum(x) = sum(x) + brr(m, bb(x))
    
48.                     Next
    
49.                 Next
    
50.                 m = m + 1
    
51.                 brr(m, 2) = kk & " 小计"
    
52.                 For x = 1 To 5
    
53.                     brr(m, bb(x)) = sum(x)
    
54.                
    
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
    

复制代码

老丢710

ykcbf1100 发表于 2024-5-13 11:50
按用料单位和供应商拆分。

运行错误，下标越界，把redim brr(1 to30)改成10000是不是就可以了？