Loop a VBA macro based off a dynamic range of cells?

[savosean]

Hello, I wanted to know if anyone knows if this is possible.

I am using Tushar Mehta's code

Option Explicit

Function RealEqual(A, B, Epsilon As Double)
    RealEqual = Abs(A - B) <= Epsilon
    End Function
Function ExtendRslt(CurrRslt, NewVal, Separator)
    If CurrRslt = "" Then ExtendRslt = NewVal _
    Else ExtendRslt = CurrRslt & Separator & NewVal
    End Function

Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _
        ByVal CurrIdx As Integer, _
        ByVal CurrTotal, ByVal Epsilon As Double, _
        ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
    Dim I As Integer
    For I = CurrIdx To UBound(InArr)
        If RealEqual(CurrTotal + InArr(I), TargetVal, Epsilon) Then
            Rslt(UBound(Rslt)) = (CurrTotal + InArr(I)) _
                & Separator & Format(Now(), "hh:mm:ss") _
                & Separator & ExtendRslt(CurrRslt, I, Separator)
            If MaxSoln = 0 Then
                If UBound(Rslt) Mod 100 = 0 Then Debug.Print UBound(Rslt) & "=" & Rslt(UBound(Rslt))
            Else
                If UBound(Rslt) >= MaxSoln Then Exit Sub
                End If
            ReDim Preserve Rslt(UBound(Rslt) + 1)
        ElseIf CurrTotal + InArr(I) > TargetVal + Epsilon Then
        ElseIf CurrIdx < UBound(InArr) Then
            recursiveMatch MaxSoln, TargetVal, InArr(), I + 1, _
                CurrTotal + InArr(I), Epsilon, Rslt(), _
                ExtendRslt(CurrRslt, I, Separator), _
                Separator
            If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
        Else
            'we've run out of possible elements and we _
             still don't have a match
            End If
        Next I
    End Sub

Function ArrLen(Arr()) As Integer
    On Error Resume Next
    ArrLen = UBound(Arr) - LBound(Arr) + 1
    End Function

Sub startSearch()
    'The selection should be a single contiguous range in a single column. _
     The first cell indicates the number of solutions wanted.  Specify zero for all. _
      The 2nd cell is the target value. _
      The rest of the cells are the values available for matching. _
      The output is in the column adjacent to the one containing the input data.
    Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer
    StartTime = Now()
    MaxSoln = Selection.Cells(1).Value
    TargetVal = Selection.Cells(2).Value
    InArr = Application.WorksheetFunction.Transpose( _
        Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
    ReDim Rslt(0)
    recursiveMatch MaxSoln, TargetVal, InArr, LBound(InArr), 0, 0.00000001, _
        Rslt, "", ", "
    Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
    ReDim Preserve Rslt(UBound(Rslt) + 1)
    Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
    Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _
        Application.WorksheetFunction.Transpose(Rslt)
    End Sub

And have a very large amount of DATA, as of now I have binded the code to Crtl-Q. Therefore, I have to manually run CTRL+Q on each range of cells to determine if values can be sum'd to 0 or not. I have over 40,000 USER ID's I have to run this on.

My question is if I can expand on this VBA code, and have it automatically run for each range of cells?

This is what my data looks like:

USER ID Values 1 0 1 -34 1 -55 1 -100 1 34 1 55 1 75 1 12 1 0 2 -90 2 -34 2 12 2 90 2 12 2 100 1 0 3 -34 3 34 3 34 3 56 3 -56 3 56 3 34 <colgroup><col width="64" style="width:48pt" span="2"> </colgroup><tbody> </tbody>
Currently I must select the cells for each unique User id, including the first two rows with the 1 and the 0 manually. Is what I am asking possible, can it be done? Thanks.

<colgroup><col width="64" style="width:48pt" span="3"> </colgroup><tbody>
</tbody>

 

[DanteAmor]

I created the macro Select_Data to invoke the macro "startSearch" for each USER ID

Option Explicit
'
Function RealEqual(A, B, Epsilon As Double)
    RealEqual = Abs(A - B) <= Epsilon
    End Function
'
Function ExtendRslt(CurrRslt, NewVal, Separator)
    If CurrRslt = "" Then ExtendRslt = NewVal _
    Else ExtendRslt = CurrRslt & Separator & NewVal
    End Function
'
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _
        ByVal CurrIdx As Integer, _
        ByVal CurrTotal, ByVal Epsilon As Double, _
        ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
    Dim i As Integer
    For i = CurrIdx To UBound(InArr)
        If RealEqual(CurrTotal + InArr(i), TargetVal, Epsilon) Then
            Rslt(UBound(Rslt)) = (CurrTotal + InArr(i)) _
                & Separator & Format(Now(), "hh:mm:ss") _
                & Separator & ExtendRslt(CurrRslt, i, Separator)
            If MaxSoln = 0 Then
                If UBound(Rslt) Mod 100 = 0 Then Debug.Print UBound(Rslt) & "=" & Rslt(UBound(Rslt))
            Else
                If UBound(Rslt) >= MaxSoln Then Exit Sub
                End If
            ReDim Preserve Rslt(UBound(Rslt) + 1)
        ElseIf CurrTotal + InArr(i) > TargetVal + Epsilon Then
        ElseIf CurrIdx < UBound(InArr) Then
            recursiveMatch MaxSoln, TargetVal, InArr(), i + 1, _
                CurrTotal + InArr(i), Epsilon, Rslt(), _
                ExtendRslt(CurrRslt, i, Separator), _
                Separator
            If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
        Else
            'we've run out of possible elements and we _
             still don't have a match
            End If
        Next i
    End Sub
'
Function ArrLen(Arr()) As Integer
    On Error Resume Next
    ArrLen = UBound(Arr) - LBound(Arr) + 1
    End Function
'
Sub startSearch()
    'The selection should be a single contiguous range in a single column. _
     The first cell indicates the number of solutions wanted.  Specify zero for all. _
      The 2nd cell is the target value. _
      The rest of the cells are the values available for matching. _
      The output is in the column adjacent to the one containing the input data.
    Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer
    StartTime = Now()
    MaxSoln = Selection.Cells(1).Value
    TargetVal = Selection.Cells(2).Value
    InArr = Application.WorksheetFunction.Transpose( _
        Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
    ReDim Rslt(0)
    recursiveMatch MaxSoln, TargetVal, InArr, LBound(InArr), 0, 0.00000001, _
        Rslt, "", ", "
    Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
    ReDim Preserve Rslt(UBound(Rslt) + 1)
    Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
    Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _
        Application.WorksheetFunction.Transpose(Rslt)
End Sub
'
Sub Select_Data()
    Dim i As Long, ini As Integer, fin As Integer
    Application.ScreenUpdating = False
    'row 2 is the beginning of the data of column "B"
    ini = 2
    For i = ini + 2 To Range("B" & Rows.Count).End(xlUp).Row + 1
        If Cells(i, "A").Value = "" Then
            fin = i - 1
            Range("B" & ini & ":" & "B" & fin).Select
            Call startSearch
            ini = i
            i = i + 2
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Regards Dante Amor

 

[savosean]

Thank you so much, I will have to try it when I get back to work after the holidays.

 

[DanteAmor]

ok, then Happy Holidays

 

[savosean]

It works, perfectly. Thank you very much, happy holidays to you as well.

 

[DanteAmor]

I'm glad to help you