格式转换及自动计算并汇总

rsfzcs

各位大侠新年好！先给各位拜个年：祝各位兔年大吉、万事如意！
请大侠帮忙解决一下。谢谢了！
问题如题，详见附件：

chxw68

1. Sub test1()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("标准")
   
7.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
8.         arr = .Range("a1").Resize(2, c)
   
9.         For j = 2 To UBound(arr, 2)
   
10.             d(arr(1, j)) = arr(2, j)
    
11.         Next
    
12.     End With
    
13.     With Worksheets("报表")
    
14.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
15.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
16.         arr = .Range("a1").Resize(r, c)
    
17.     End With
    
18.     ReDim brr(1 To (UBound(arr) - 1) * (UBound(arr, 2) - 6), 1 To 7)
    
19.     m = 0
    
20.     For i = 2 To UBound(arr)
    
21.         For j = 6 To UBound(arr, 2) - 1
    
22.             If Len(arr(i, j)) <> 0 Then
    
23.                 m = m + 1
    
24.                 For k = 1 To 3
    
25.                     brr(m, k) = arr(i, k)
    
26.                 Next
    
27.                 brr(m, 4) = arr(1, j)
    
28.                 brr(m, 5) = arr(i, j)
    
29.                 If d.exists(arr(1, j)) Then
    
30.                     brr(m, 6) = d(arr(1, j))
    
31.                     brr(m, 7) = brr(m, 5) * brr(m, 6)
    
32.                 End If
    
33.             End If
    
34.         Next
    
35.     Next
    
36.     With Worksheets("转换（1）")
    
37.         .UsedRange.Offset(1, 0).Delete
    
38.         .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
39.     End With
    
40. End Sub
    

复制代码

chxw68

3个问题写了3段代码 。

rsfzcs

chxw68 发表于 2023-2-1 21:14
3个问题写了3段代码 。

正是所需，非常感谢！

c13222131862

mARK，学习一下

和乐隐士

谢谢chxw68老师分享的代码，收益菲浅！！！

rsfzcs

chxw68 发表于 2023-2-1 21:14
3个问题写了3段代码 。

你好！
非常感谢你以前的帮助，为我解决了不少工作上的难题，也提高了工作效率。
你上次帮忙解决的这个问题，现在要加两个品种上去，但我不知道怎样修改程序才能计算结果加上去。
特请你帮忙解决一下。如果今后还要添加品种的话，该怎么弄？
谢谢你！

chxw68

rsfzcs 发表于 2023-3-30 16:37
你好！
非常感谢你以前的帮助，为我解决了不少工作上的难题，也提高了工作效率。
你上次帮忙解决的这个 ...

这是蓝桥玄霜老师的代码，你找他改吧。

rsfzcs

chxw68 发表于 2023-3-30 16:47
这是蓝桥玄霜老师的代码，你找他改吧。

哦，不好意思。谢谢您！