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

S

savosean

New Member
Joined
Jun 7, 2018
Messages
36
Hello, I wanted to know if anyone knows if this is possible.

I am using Tushar Mehta's code

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:

[TABLE="width: 192"]
<colgroup><col width="64" style="width:48pt" span="3"> </colgroup><tbody>[TR]
[TD="width: 64, bgcolor: transparent"][TABLE="width: 128"]
<colgroup><col width="64" style="width:48pt" span="2"> </colgroup><tbody>[TR]
[TD="width: 64, bgcolor: transparent"]USER ID[/TD]
[TD="width: 64, bgcolor: transparent"]Values[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"]1[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]1[/TD]
[TD="bgcolor: transparent, align: right"]-34[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]1[/TD]
[TD="bgcolor: transparent, align: right"]-55[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]1[/TD]
[TD="bgcolor: transparent, align: right"]-100[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]1[/TD]
[TD="bgcolor: transparent, align: right"]34[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]1[/TD]
[TD="bgcolor: transparent, align: right"]55[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]1[/TD]
[TD="bgcolor: transparent, align: right"]75[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]1[/TD]
[TD="bgcolor: transparent, align: right"]12[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"]1[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]2[/TD]
[TD="bgcolor: transparent, align: right"]-90[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]2[/TD]
[TD="bgcolor: transparent, align: right"]-34[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]2[/TD]
[TD="bgcolor: transparent, align: right"]12[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]2[/TD]
[TD="bgcolor: transparent, align: right"]90[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]2[/TD]
[TD="bgcolor: transparent, align: right"]12[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]2[/TD]
[TD="bgcolor: transparent, align: right"]100[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"]1[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]3[/TD]
[TD="bgcolor: transparent, align: right"]-34[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]3[/TD]
[TD="bgcolor: transparent, align: right"]34[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]3[/TD]
[TD="bgcolor: transparent, align: right"]34[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]3[/TD]
[TD="bgcolor: transparent, align: right"]56[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]3[/TD]
[TD="bgcolor: transparent, align: right"]-56[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]3[/TD]
[TD="bgcolor: transparent, align: right"]56[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"]3[/TD]
[TD="bgcolor: transparent, align: right"]34[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD="width: 64, bgcolor: transparent"][/TD]
[TD="width: 64, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]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.
[/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent, align: right"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
</tbody>[/TABLE]
 
Sort by date Sort by votes
I created the macro Select_Data to invoke the macro "startSearch" for each USER ID


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
'
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Question Question
VBA run code based off cell value
Replies
1
Views
847
igold
igold
C
  • Question Question
Loop validation, copy output from same range and paste in different ranges
Replies
1
Views
799
RoryA
RoryA
M
  • Question Question
VBA Code - Run Code if cell value is not blank
Replies
0
Views
654
MHamid
M
S
  • Question Question
Solver combinations sum=0
Replies
4
Views
3K
savosean
S
S
  • Question Question
Expanding on Tushar Mehta code?
Replies
0
Views
830
savosean
S

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top