VBA一对多如何求和勾对？

excel1202

VBA一对多如何求和勾对？

即以A列编号的数值等于G列相同编号的数值之和，勾对相符的标上相同的颜色，找不到的就不用管它。

taller

代码测试没有问题，不知道你是如何用的

VBA一对多如何求和勾对.zip (16.3 KB, 下载次数: 14)

2024-3-17 13:58 上传

点击文件名下载附件

shiruiqiang

编号做字典，颜色值做值

taller

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.17
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(.Rows.Count, "g").End(xlUp).Row
   
7.         arr = .[g1].Resize(r, 2)
   
8.         For i = 2 To UBound(arr)
   
9.             s = .Cells(i, 7).Interior.ColorIndex
   
10.             d(s) = d(s) + arr(i, 2)
    
11.         Next
    
12.         arr = .[a1].Resize(7, 2)
    
13.         For i = 2 To UBound(arr)
    
14.             s = .Cells(i, 1).Interior.ColorIndex
    
15.             If d.Exists(s) Then
    
16.                 arr(i, 2) = d(s)
    
17.             End If
    
18.         Next
    
19.         .[a1].Resize(7, 2) = arr
    
20.     End With
    
21.     Set d = Nothing
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码

excel1202

ykcbf1100 发表于 2024-3-17 09:45
参与一下。。。

原始的表格是没有颜色的。清除颜色后，运行不正确啊，A列被修改了

kittli

练习！！！

excel1202

taller 发表于 2024-3-17 09:21

1. Sub Demo()
   
2.     Columns("A:H").Interior.Pattern = xlNone
   
3.     Range("C1").Select
   
4.     Dim oDic As Object, oDicRng As Object, rngData As Range
   
5.     Dim i As Long, sKey As String, arrData
   
6.     Set oDic = CreateObject("Scripting.Dictionary")
   
7.     Set oDicRng = CreateObject("Scripting.Dictionary")
   
8.     Set rngData = Range("G1").CurrentRegion
   
9.     arrData = rngData.Value
   
10.     For i = LBound(arrData) + 1 To UBound(arrData)
    
11.         sKey = arrData(i, 1)
    
12.         If oDic.exists(sKey) Then
    
13.             oDic(sKey) = oDic(sKey) + arrData(i, 2)
    
14.             Set oDicRng(sKey) = Application.Union(oDicRng(sKey), Cells(i, "G").Resize(1, 2))
    
15.         Else
    
16.             oDic(sKey) = Val(arrData(i, 2))
    
17.             Set oDicRng(sKey) = Cells(i, "G").Resize(1, 2)
    
18.         End If
    
19.     Next i
    
20.     Dim lastRow As Long, osht As Worksheet, ic As Long
    
21.     ActiveSheet.Cells.Interior.Color = xlNone
    
22.     lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
23.     ic = 2    '请自行调整填充颜色
    
24.     For i = 2 To lastRow
    
25.         sKey = Cells(i, 1)
    
26.         If Len(sKey) > 0 Then
    
27.             If Val(Cells(i, 2)) = Val(oDic(sKey)) Then
    
28.                 Set oDicRng(sKey) = Application.Union(oDicRng(sKey), Cells(i, "A").Resize(1, 2))
    
29.                 ic = ic + 1
    
30.                 oDicRng(sKey).Interior.ColorIndex = ic
    
31.             End If
    
32.         End If
    
33.     Next
    
34. End Sub

复制代码

运行结果不正确啊！

excel1202

kittli 发表于 2024-3-17 13:10
练习！！！

怪我没说清楚：原始表格是没有颜色的，需要将勾对结果标志上颜色。

excel1202

taller 发表于 2024-3-17 09:21

谢谢版主，但运行结果不正确啊！