Twice a SUMIF with Overwrite
Workbook Download (Dropbox)
Couldn't find any indication of SUMIFS, so I did it as if there is twice a SUMIF:
For Columns A and C, and for Columns B and D.
Option Explicit
Sub SumUnique(UniqueFirstCell As Range, ValueFirstCell As Range)
Dim rng As Range ' Unique Last Used Cell
Dim dict As Object ' Dictionary
Dim key As Variant ' Dictionary Key Counter (For Each Control Variable)
Dim vntU As Variant ' Unique Range Array
Dim vntV As Variant ' Value Range Array
Dim vntUT As Variant ' Unique Array
Dim vntVT As Variant ' Value Array
Dim curV As Variant ' Current Value
Dim NorS As Long ' Source Number of Rows
Dim NorT As Long ' Target Number of Rows
Dim i As Long ' Source/Target Row Counter
' Copy Unique Range to Unique Range Array.
With UniqueFirstCell
Set rng = .Worksheet.Columns(.Column) _
.Find("*", , xlFormulas, , , xlPrevious)
Set rng = .Resize(rng.Row - .Row + 1)
End With
vntU = rng
' Copy Value Range to Value Range Array.
With ValueFirstCell
Set rng = .Worksheet.Columns(.Column) _
.Find("*", , xlFormulas, , , xlPrevious)
Set rng = .Resize(rng.Row - .Row + 1)
End With
vntV = rng
' Create Unique Values and SumIf Values in Dictionary.
Set dict = CreateObject("Scripting.Dictionary")
NorS = UBound(vntU)
For i = 1 To NorS
curV = vntU(i, 1)
If curV <> "" Then
dict(curV) = dict(curV) + vntV(i, 1)
End If
Next
NorT = dict.Count
' Resize Unique and Value Arrays to Target Number of Rows.
ReDim vntUT(1 To NorT, 1 To 1)
ReDim vntVT(1 To NorT, 1 To 1)
i = 0
For Each key In dict.keys
i = i + 1
' Write Dictionary Keys to Unique Array.
vntUT(i, 1) = key
' Write Dictionary Values to Value Array.
vntVT(i, 1) = dict(key)
Next
' Copy Unique Array to Target Unique Range.
With UniqueFirstCell
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
rng.ClearContents
Set rng = .Resize(NorT)
End With
rng = vntUT
' Copy Value Array to Target Value Range.
With ValueFirstCell
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
rng.ClearContents
Set rng = .Resize(NorT)
End With
rng = vntVT
End Sub
Sub Uni()
Uni1
Uni2
End Sub
Sub Uni1()
Const cUni As String = "A2"
Const cVal As String = "C2"
With ThisWorkbook.Worksheets("Sheet1")
SumUnique .Range(cUni), .Range(cVal)
End With
End Sub
Sub Uni2()
Const cUni As String = "B2"
Const cVal As String = "D2"
With ThisWorkbook.Worksheets("Sheet1")
SumUnique .Range(cUni), .Range(cVal)
End With
End Sub
I created two command buttons and put the following code into the sheet module:
Option Explicit
Private Sub cmdRevert_Click()
[A2:D31] = [J2:M31].Value
End Sub
Private Sub cmdUnique_Click()
Uni
End Sub
