Sub SumWithMatchCrit()
Dim lr As Long
Dim cll As Range
Dim test As Range
Dim trng As Range
Dim rng As Range
Dim crit As Double
Dim tVal As Double
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("B2:B" & lr)
rng.Interior.Pattern = xlNone
crit = ws.Cells(2, 3).Value
For Each cll In rng
Set trng = cll
For Each test In rng
If Intersect(test, trng) Is Nothing Then
tVal = test.Value + WorksheetFunction.Sum(trng)
If Round(tVal, 1) = Round(crit, 1) Then
Union(trng, test).Interior.Color = RGB(255, 255, 0)
Union(trng.Offset(0, -1), test.Offset(0, -1)).Interior.Color = RGB(255, 255, 0)
ElseIf tVal < crit Then
Set trng = Union(trng, test)
End If
End If
Next test
If Not trng Is Nothing Then Debug.Print trng.Address
Next cll
Call CopyHighlightedCells
End Sub
Sub CopyHighlightedCells()
Dim LastRowA As Long, LastRowB As Long
Dim ws As Worksheet
Dim HighlightedValuesA() As Variant
Dim HighlightedValuesB() As Variant
Dim i As Long, j As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
LastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
LastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
ReDim HighlightedValuesA(1 To LastRowA - 1)
ReDim HighlightedValuesB(1 To LastRowB - 1)
j = 1
For i = 2 To LastRowA
If ws.Cells(i, "A").Interior.Color <> RGB(255, 255, 255) Then
HighlightedValuesA(j) = ws.Cells(i, "A").Value
j = j + 1
End If
Next i
j = 1
For i = 2 To LastRowB
If ws.Cells(i, "B").Interior.Color <> RGB(255, 255, 255) Then
HighlightedValuesB(j) = ws.Cells(i, "B").Value
j = j + 1
End If
Next i
For i = 1 To UBound(HighlightedValuesA)
ws.Cells(i + 1, "D").Value = HighlightedValuesA(i)
Next i
For i = 1 To UBound(HighlightedValuesB)
ws.Cells(i + 1, "E").Value = HighlightedValuesB(i)
Next i
End Sub