求助VBA在原数据基础上 生成多一列标注列数据

aails6543

[已解决]
老师们好，

sheet1原始数据，可能存在很多行相同数据, 或不同批次;    sheet2为最终效果数据
即在原数据上，整理后新增多1列数据：Z列标题为【标注列数据】的数据，数量上有相应累加。

因我本人经常只用函数处理效率低下，故求助 用VBA数组或字典解决 ，
希望能得到老师们帮助，谢谢！谢谢！

工作簿1.rar (32.43 KB, 下载次数: 11)

2024-2-6 10:05 上传

点击文件名下载附件

多谢各位老师帮助，感谢！感谢！[已解决]

fzxba

1. Sub test0()
   
2.   Dim ar, br() As Double, Dict As Object, strKey As String
   
3.   Dim i As Long
   
4.   Set Dict = CreateObject("Scripting.Dictionary")
   
5.   Sheet2.Activate
   
6.   ar = Range("S11", Cells(Rows.Count, "L").End(xlUp)).Value
   
7.   ReDim br(1 To UBound(ar), 0)
   
8.   For i = 1 To UBound(ar)
   
9.     strKey = ar(i, 1) & "|" & ar(i, 5) & "|" & ar(i, 7)
   
10.     Dict(strKey) = Dict(strKey) + Val(ar(i, 8))
    
11.     br(i, 0) = Dict(strKey)
    
12.   Next
    
13.   Range("Z11").Resize(UBound(br)) = br
    
14.   Set Dict = Nothing
    
15.   Beep
    
16. End Sub

复制代码

fzxba

工作簿1.zip (42.27 KB, 下载次数: 13)

2024-2-6 10:30 上传

点击文件名下载附件

清风竹-

请看附件。

x-xx-xx

鄂龙蒙

【整理累计数量】.rar (38.1 KB, 下载次数: 11)

2024-2-6 10:42 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.6
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("Sheet1").UsedRange
   
5.     With Sheets("Sheet2")
   
6.         .[a11:y10000] = ""
   
7.         .[a10].Resize(UBound(arr), UBound(arr, 2)) = arr
   
8.         .[z10] = "累计标注"
   
9.         Set Rng = .UsedRange
   
10.         arr = .UsedRange
    
11.         For i = 10 To UBound(arr)
    
12.             s = arr(i, 12) & "|" & arr(i, 16) & "|" & arr(i, 18)
    
13.             d(s) = d(s) + arr(i, 19)
    
14.             arr(i, 26) = d(s)
    
15.         Next
    
16.         .UsedRange = arr
    
17.     End With
    
18.     MsgBox "OK！"
    
19. End Sub
    
20. 
    

复制代码

ykcbf1100

附件供参考。。。

zhangcheng6688

借个楼学习一下数组，哈
Sub test()
arr = Sheets("sheet2").[a11].CurrentRegion
lastr = Sheets("sheet2").Cells(Rows.Count, "a").End(xlUp).Row
brr = Range("z10:z" & lastr)
bz = False
For i = 2 To UBound(arr)
   If arr(i, 1) <> "" Then
      For j = i + 1 To UBound(arr)
         If arr(j, 1) <> "" Then
            If arr(i, 12) = arr(j, 12) And arr(i, 16) = arr(j, 16) And arr(i, 18) = arr(j, 18) Then
               If brr(i, 1) = "" Then
                  brr(i, 1) = arr(i, 19)
                  brr(j, 1) = arr(i, 19) + arr(j, 19)
                  t = brr(j, 1)
                  arr(j, 1) = vbNullString
                  bz = True
               Else
                  brr(j, 1) = t + arr(j, 19)
                  t = brr(j, 1)
                  arr(j, 1) = vbNullString
              End If
             End If
         End If
       Next
       If bz = True Then
          bz = False
       Else
          brr(i, 1) = arr(i, 19)
       End If
   End If
Next
Sheets("sheet2").[z10].Resize(UBound(brr), 1) = brr
End Sub

zhangcheng6688

清风竹- 发表于 2024-2-6 10:30
请看附件。

向老师学习字典，感谢