Dim aSum As Integer

 Dim tSum As Integer

 Dim judge() As Integer

 Dim arrMax As Integer

 Dim arr

 Dim location() As Integer

 Function Test()

     Dim arrWmax As Integer

     Dim Rng As Range

     Dim beginRow As Integer

     Dim beginLine As Integer

     Set Rng = Application.InputBox(prompt:="Please Select....", Type:=)

     rr = Rng.Address

     beginRow = Rng.Column

     beginLine = Rng.Row

     arr = Range(rr)

     aSum =

     arrMax = UBound(arr)

     arrWmax = UBound(arr, )

     For loca =  To arrMax

         location(loca) = beginLine

         beginLine = beginLine +

     Next

     For col =  To arrWmax  'modify

         tSum = arr(, col)

         Call subTest(, beginRow)

     Next

 End Function

 Function subTest(n As Integer, beginRow As Integer)

     If aSum > tSum Then

         Exit Function

     End If

     Dim i As Integer

     Dim j As Integer

     If aSum = tSum Then

         For i =  To n

             If judge(i) =  Then

                 Sheets().Cells(location(i), beginRow).Interior.Color = vbRed

             End If

         Next

         Exit Function

     End If

     If n = arrMax Then

         Exit Function

     End If

     For j = n To arrMax

         If judge(j) =  Then

             judge(j) =

             aSum = aSum + arr(j, )

             Call subTest(j, beginRow)

             judge(j) =

             aSum = aSum - arr(j, )

             If j < arrMax Then

                 While arr(j, ) = arr(j + , )

                       j = j +

                 Wend

             End If

         End If

     Next

 End Function