Adding Duplicates
(Updated)
Option Explicit
Sub TEST()
Dim S_1 As Worksheet
Dim S_2 As Worksheet
Dim R As Long
Dim str_F As String
Set S_1 = Worksheets("Data")
Set S_2 = Worksheets("Summary")
R = S_1.Cells(Rows.Count, 1).End(xlUp).Row
If R < 2 Then GoTo e:
S_2.Range("A:C").Clear
S_1.Range("A1:C" & R).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=S_2.Range("A1"), _
Unique:=True
str_F = "(__!$A$2:$A$~~&__!$B$2:$B$~~=A2&B2)*__!$C$2:$C$~~ )"
str_F = "=SUMPRODUCT(" & str_F
str_F = Application.Substitute(str_F, "__", S_1.Name)
str_F = Application.Substitute(str_F, "~~", R)
R = S_2.Cells(Rows.Count, 1).End(xlUp).Row
If R < 2 Then GoTo e:
With S_2.Range("C2:C" & R)
.Formula = str_F
.Value = .Value
End With
e:
Application.ScreenUpdating = True
End Sub
--
Regards,
Soo Cheon Jheong
Seoul, Korea
_ _
^вп^
--
|