Sub test() Dim myDic As Object 'Scripting.Dictionary Dim myCol() As Collection Dim Cnt As Long Dim myItem Dim Rng As Range Dim Targ As Long Dim myVar Dim i As Long, j As Long, k As Long Dim mySum As Long, Ans As Long Set myDic = CreateObject("Scripting.Dictionary") With Range("A3", Range("A" & Rows.Count).End(xlUp).Offset(, 1)) myVar = .Value Set Rng = .Offset(, 2).Resize(, 1) End With With Rng .ClearContents .NumberFormat = "@" End With Targ = Range("D3").Value For i = 1 To UBound(myVar, 1) If Not myDic.Exists(myVar(i, 2)) Then ReDim Preserve myCol(Cnt) Set myCol(Cnt) = New Collection myCol(Cnt).Add i myDic.Add myVar(i, 2), myCol(Cnt) Cnt = Cnt + 1 Else myDic(myVar(i, 2)).Add i End If Next i For i = 0 To UBound(myCol) For j = 1 To 2 ^ myCol(i).Count - 1 mySum = 0 For k = 0 To myCol(i).Count - 1 mySum = mySum + (Int(j / 2 ^ k) Mod 2) * myVar(myCol(i)(k + 1), 1) If mySum > Targ Then Exit For Next k If mySum = Targ Then Ans = Ans + 1 For k = 0 To myCol(i).Count - 1 If Int(j / 2 ^ k) Mod 2 = 1 Then Rng(myCol(i)(k + 1)).Value = Rng(myCol(i)(k + 1)).Value & " " & Ans End If Next k End If Next j Next i End Sub