玖叶教程网

最近有朋友要求对他的表格按颜色汇总求和，于是写了这段代码，一起分享一下效果。

Sub 颜色求和()

'感谢“E殿园”提供友情技术支持

Dim myRange As Range

Dim aCell As Range

Dim D As Object

Dim Arr1 As Variant

Dim Arr2 As Variant

Dim outRange As Range

On Error Resume Next

Set myRange = Application.Intersect(ActiveSheet.Range(GetAreaAddress("请选择数据区域：")), ActiveSheet.UsedRange)

If myRange Is Nothing Then Exit Sub

Set D = CreateObject("scripting.dictionary")

For Each aCell In myRange

If aCell.Value <> "" And IsNumeric(aCell) Then

If Not D.exists(aCell.Interior.Color) Then

D.Add aCell.Interior.Color, 0

End If

D(aCell.Interior.Color) = D(aCell.Interior.Color) + aCell.Value

End If

Next

If D.Count = 0 Then Exit Sub

Arr1 = D.keys

Arr2 = D.items

Set outRange = aRange

Application.ScreenUpdating = False

For i = LBound(Arr1) To UBound(Arr1)

outRange.Offset(0, i).Interior.Color = Arr1(i)

outRange.Offset(1, i) = Arr2(i)

Next

Range(outRange, outRange.Offset(1, UBound(Arr1))).Borders.LineStyle = xlContinuous

Application.ScreenUpdating = True

ShowMsg "汇总结束！" & Chr(13) & "关注E殿园公众帐号并回复“颜色汇总源码”可下载源码！"

End Sub

Function aRange() As Range

Dim a As Range

Set a = ActiveSheet.Range(GetAreaAddress("请选择输出位置："))

If InStr(1, a.Address, ":") > 0 Then

Set aRange = ActiveSheet.Range(Split(a.Address, ":")(0))

Else

Set aRange = a

End If

End Function

Function GetAreaAddress(ByVal str As String) 'E殿园提供

Dim MyCell As Range

On Error GoTo ErrorHadle

Set MyCell = Application.InputBox(prompt:=str, Default:=Application.Selection.Address, Type:=8)

GetAreaAddress = MyCell.Address

Exit Function

ErrorHadle:

GetAreaAddress = ""

End Function

Sub ShowMsg(ByVal msg As String)

MsgBox msg, vbOKOnly, "E殿园"

End Sub