Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Option Explicit
Sub SumIteration()
Dim CandidateSums(3337 To 3454) As New Collection
Dim lngItems(0 To 22) As Long
Dim lngPower(0 To 22) As Long
Dim lngLoop As Long
Dim lngSum As Long
For lngLoop = 0 To 22
lngPower(lngLoop) = 2 ^ lngLoop
Next
lngItems(0) = 124
lngItems(1) = 170
lngItems(2) = 210
lngItems(3) = 296
lngItems(4) = 330
lngItems(5) = 400
lngItems(6) = 476
lngItems(7) = 492
lngItems(8) = 522
lngItems(9) = 544
lngItems(10) = 564
lngItems(11) = 570
lngItems(12) = 650
lngItems(13) = 662
lngItems(14) = 686
lngItems(15) = 724
lngItems(16) = 750
lngItems(17) = 780
lngItems(18) = 780
lngItems(19) = 786
lngItems(20) = 996
lngItems(21) = 996
lngItems(22) = 1074
For lngLoop = 2 ^ 23 - 1 To 1 Step -1
lngSum = SumItStatic(lngLoop, lngItems(), 3455)
Select Case lngSum
Case 3337 To 3454
CandidateSums(lngSum).Add lngLoop
End Select
Next
Stop
End Sub
Function SumItStatic(parmMask As Long, parmItems() As Long, parmSumLimit As Long) As Long
Static lngPower() As Long
Static IsInitialized As Boolean
Dim lngLoop As Long
Dim lngSum As Long
Dim lngUbound As Long
lngUbound = UBound(parmItems)
If IsInitialized Then
Else
ReDim lngPower(0 To lngUbound)
For lngLoop = 0 To lngUbound
lngPower(lngLoop) = 2 ^ lngLoop
Next
IsInitialized = True
End If
For lngLoop = lngUbound To 0 Step -1
If (parmMask And lngPower(lngLoop)) <> 0 Then
lngSum = lngSum + parmItems(lngLoop)
If lngSum > parmSumLimit Then
SumItStatic = lngSum
Exit Function
End If
End If
Next
SumItStatic = lngSum
End Function
0.25 0.25 0.25 0.25 1
0.25 0.25 0.25 2.25 3
0.25 0.25 2.25 2.25 5
0.25 2.25 2.25 2.25 7
2.25 2.25 2.25 2.25 9
==============================
0.5 0.5 0.5 0.5 2
0.5 0.5 0.5 1.5 3
0.5 0.5 1.5 1.5 4
0.5 1.5 1.5 1.5 5
1.5 1.5 1.5 1.5 6
'Count total candidate sums
lngSum = 0
For lngLoop = 3337 To 3454
lngSum = lngSum + CandidateSums(lngLoop).Count
Next
Dim lngIndexedSums() As Long
ReDim lngIndexedSums(lngSum)
Dim lngIndexedPosition As Long 'Current position to store next item
Dim lngTarget, lngLowerTarget, lngUpperTarget As Long
Dim lngTotalTargetItems, lngLowerTotal, lngUpperTotal As Long
lngIndexedPosition = 0
lngTarget = 3396
'1st add all items in target index to array
For lngLoop = 1 To CandidateSums(lngTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget + 1
Do While lngLowerTarget >= 3337 And lngUpperTarget <= 3454
lngLowerTotal = CandidateSums(lngLowerTarget).Count
lngUpperTotal = CandidateSums(lngUpperTarget).Count
'Determine which collection has larger number of items for this offset
If lngLowerTotal = lngUpperTotal Then
'Count is equal for this iteration so set loop count to Count
lngTotalTargetItems = lngLowerTotal
Else
'Set loop count to higher of 2
If lngLowerTotal > lngUpperTotal Then
lngTotalTargetItems = lngLowerTotal
Else
lngTotalTargetItems = lngUpperTotal
End If
End If
For lngLoop = 1 To lngTotalTargetItems
'Add next sum from lower offset target if it exists
If lngLoop <= lngLowerTotal Then
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngLowerTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
End If
'Add next sum from upper offset target if it exists
If lngLoop <= lngUpperTotal Then
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngUpperTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
End If
Next
lngLowerTarget = lngLowerTarget - 1
lngUpperTarget = lngUpperTarget + 1
Loop
'Check to see if there is an odd man out and add it if necessary
If lngLowerTarget = 3337 Then
'There is 1 more lower offset to iterate through
For lngLoop = 1 To CandidateSums(lngLowerTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngLowerTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
If lngUpperTarget = 3454 Then
'There is 1 more upper offset to iterate through
For lngLoop = 1 To CandidateSums(lngUpperTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngUpperTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
'Validate all positions of indexed array contain sums
Dim bZeroFound As Boolean: bZeroFound = False
Dim lngIndexedValue As Long
For lngLoop = 0 To UBound(lngIndexedSums()) - 1
lngIndexedValue = lngIndexedSums(lngLoop) 'set watch to see values
If Not lngIndexedValue > 0 Then
bZeroFound = True
End If
Next
Debug.Print "LowerTargetOffset: " & Str(lngLowerTarget)
Debug.Print "UpperTargetOffset: " & Str(lngUpperTarget)
Debug.Print "Zero Found: " & Str(bZeroFound)
Sum Sum/4 Preference
------ -------- -----------
13580 3395 None
13581 3395.25 Lower
13582 3395.5 None
13583 3395.75 Upper
13584 3396 None
13585 3396.25 Lower
13586 3396.5 None
13587 3396.75 Upper
13588 3397 None
From To Variance
----- ------- ---------
1 408 0.25
409 788 2.25
789 1150 6.25
1151 1562 12.25
1563 1953 20.25
'iterating the array
For lngBestItems = 0 To Ubound(itemarray) - 4
Vector(0) = lngBestItems
Vector(1) = lngBestItems + 1
Vector(2) = 0
Vector(3) = 0
Depth = 1
Do
FindItems Vector(), Depth
If Vector(3) = 0 Then 'could also use -1
'increment the lowest non-zero Vector item
Else 'evaluate fitness
If PriorFitness > Fitness(Vector()) Then
PriorFitness = Fitness(Vector())
BestVectorSoFar = Vector
End If
'increment the next-to-lowest Vector item
End If
Loop Until SomeCriteriaIsMet
Next
Sub FindItems(parmVector(), parmDepth)
Dim lngMask As Long
Dim lngLoop As Integer
'Do I need to search starting at this level or somewhere lower?
If parmVector(parmDepth+1)<>0 Then
FindItems(parmVector(), parmDepth+1)
End If
If parmVector(parmDepth+1) = 0 Then
'Look forward at this level
End If
'construct the bit mask of all higher combination items
For lngLoop = 0 To ParmDepth-1
lngMask = lngMask OR ItemArray(parmVector(lngLoop))
Next
For lngLoop = parmVector(parmDepth) To Ubound(ItemArray)-(4-Depth)
If (ItemArray(lngLoop) And lngMask) = 0 Then
parmVector(Depth) = lngLoop
Exit For
End If
Next
If Depth < 3 Then 'look lower
FindItems(parmVector(), parmDepth+1)
Else
Exit Sub
End If
Next
Option Explicit
Dim lngIndexedSums() As Long
Sub SumIteration()
Dim CandidateSums(3337 To 3454) As New Collection
Dim Groups() As String
Dim lngItems(0 To 22) As Long
Dim lngPower(0 To 22) As Long
Dim lngLoop As Long
Dim lngSum As Long
For lngLoop = 0 To 22
lngPower(lngLoop) = 2 ^ lngLoop
Next
lngItems(0) = 124
lngItems(1) = 170
lngItems(2) = 210
lngItems(3) = 296
lngItems(4) = 330
lngItems(5) = 400
lngItems(6) = 476
lngItems(7) = 492
lngItems(8) = 522
lngItems(9) = 544
lngItems(10) = 564
lngItems(11) = 570
lngItems(12) = 650
lngItems(13) = 662
lngItems(14) = 686
lngItems(15) = 724
lngItems(16) = 750
lngItems(17) = 780
lngItems(18) = 780
lngItems(19) = 786
lngItems(20) = 996
lngItems(21) = 996
lngItems(22) = 1074
For lngLoop = 2 ^ 23 - 1 To 1 Step -1
lngSum = SumItStatic(lngLoop, lngItems(), 3455)
Select Case lngSum
Case 3337 To 3454
CandidateSums(lngSum).Add lngLoop
End Select
Next
'Count total candidate sums
lngSum = 0
For lngLoop = 3337 To 3454
lngSum = lngSum + CandidateSums(lngLoop).Count
Next
ReDim lngIndexedSums(lngSum)
Dim lngIndexedPosition As Long 'Current position to store next item
Dim lngTarget, lngLowerTarget, lngUpperTarget As Long
Dim lngLowerTotal, lngUpperTotal As Long
Dim lngLowerValue, lngUpperValue As Long
Dim lngItemSumTotal As Long
For lngLoop = 0 To UBound(lngItems)
lngItemSumTotal = lngItemSumTotal + lngItems(lngLoop)
Next
Select Case lngItemSumTotal Mod 4
Case 0 'exact integer
lngTarget = lngItemSumTotal / 4
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget + 1
Case 1 '.25
lngTarget = Round(lngItemSumTotal / 4, 0)
lngLowerTarget = lngTarget
lngUpperTarget = lngTarget + 1
Case 2 '.5
lngTarget = 0
lngLowerTarget = Int(lngItemSumTotal / 4)
lngUpperTarget = lngLowerTarget + 1
Case 3 '.75
lngTarget = Round(lngItemSumTotal / 4, 0)
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget
End Select
'Debug.Print "MOD:" & Str(lngItemSumTotal Mod 4)
'Debug.Print "Target: " & Str(lngTarget)
'Debug.Print "LowerTarget: " & Str(lngLowerTarget)
'Debug.Print "UpperTarget: " & Str(lngUpperTarget)
Dim lngLowerMergePosition, lngUpperMergePosition As Long
lngIndexedPosition = 0
Do While lngTarget <> -1
If lngTarget = lngLowerTarget Or lngTarget = lngUpperTarget Then
'MOD 1 or 3 so add all values from single target
For lngLoop = 1 To CandidateSums(lngTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
'Alternate to next target
If lngTarget = lngLowerTarget Then
lngLowerTarget = lngTarget - 1
If lngUpperTarget <= 3454 Then
lngTarget = lngUpperTarget
Else
If lngLowerTarget >= 3337 Then
lngTarget = lngLowerTarget
Else
lngTarget = -1
End If
End If
Else
lngUpperTarget = lngTarget + 1
If lngLowerTarget >= 3337 Then
lngTarget = lngLowerTarget
Else
If lngUpperTarget <= 3454 Then
lngTarget = lngUpperTarget
Else
lngTarget = -1
End If
End If
End If
Else
'MOD 0 or 2
If lngTarget > 0 Then 'MOD 0 so add exact target values first
For lngLoop = 1 To CandidateSums(lngTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
lngTarget = 0 'Start merging
End If
'Merge largest items from lower & upper target groups
lngLowerMergePosition = 1
lngUpperMergePosition = 1
lngLowerTotal = CandidateSums(lngLowerTarget).Count
lngUpperTotal = CandidateSums(lngUpperTarget).Count
Do While lngLowerMergePosition <= lngLowerTotal And _
lngUpperMergePosition <= lngUpperTotal
lngLowerValue = CandidateSums(lngLowerTarget).Item(lngLowerMergePosition)
lngUpperValue = CandidateSums(lngUpperTarget).Item(lngUpperMergePosition)
If lngLowerValue >= lngUpperValue Then
lngIndexedSums(lngIndexedPosition) = lngLowerValue
lngLowerMergePosition = lngLowerMergePosition + 1
Else
lngIndexedSums(lngIndexedPosition) = lngUpperValue
lngUpperMergePosition = lngUpperMergePosition + 1
End If
lngIndexedPosition = lngIndexedPosition + 1
Loop
If lngLowerMergePosition <= lngLowerTotal Then
'Add remaining lower target values
For lngLoop = lngLowerMergePosition To CandidateSums(lngLowerTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngLowerTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
If lngUpperMergePosition <= lngUpperTotal Then
'Add remaining upper target values
For lngLoop = lngUpperMergePosition To CandidateSums(lngUpperTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngUpperTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
'Determine next upper/lower targets
lngLowerTarget = lngLowerTarget - 1
lngUpperTarget = lngUpperTarget + 1
If lngLowerTarget < 3337 Or lngUpperTarget > 3454 Then
If lngLowerTarget < 3337 Then
If lngUpperTarget <= 3454 Then
'Upper target(s) still exist so add values
lngTarget = lngUpperTarget
Else
'Both outside limits so exit loop
lngTarget = -1
End If
Else
lngTarget = lngLowerTarget
End If
End If
End If
Loop
End Sub
Function SumItStatic(parmMask As Long, parmItems() As Long, parmSumLimit As Long) As Long
Static lngPower() As Long
Static IsInitialized As Boolean
Dim lngLoop As Long
Dim lngSum As Long
Dim lngUbound As Long
lngUbound = UBound(parmItems)
If IsInitialized Then
Else
ReDim lngPower(0 To lngUbound)
For lngLoop = 0 To lngUbound
lngPower(lngLoop) = 2 ^ lngLoop
Next
IsInitialized = True
End If
For lngLoop = lngUbound To 0 Step -1
If (parmMask And lngPower(lngLoop)) <> 0 Then
lngSum = lngSum + parmItems(lngLoop)
If lngSum > parmSumLimit Then
SumItStatic = lngSum
Exit Function
End If
End If
Next
SumItStatic = lngSum
End Function
Option Explicit On
Module Module1
Public lngIndexedSums() As Long
Sub SumIteration()
Dim Groups() As String
Dim lngItems(0 To 22) As Long
Dim lngPower(0 To 22) As Long
Dim lngEnumerate As Long
Dim lngLoop As Integer
Dim lngSum As Integer
Dim lngCandidateCount As Integer
For lngLoop = 0 To 22
lngPower(lngLoop) = 2 ^ lngLoop
Next
lngItems(0) = 124
lngItems(1) = 170
lngItems(2) = 210
lngItems(3) = 296
lngItems(4) = 330
lngItems(5) = 400
lngItems(6) = 476
lngItems(7) = 492
lngItems(8) = 522
lngItems(9) = 544
lngItems(10) = 564
lngItems(11) = 570
lngItems(12) = 650
lngItems(13) = 662
lngItems(14) = 686
lngItems(15) = 724
lngItems(16) = 750
lngItems(17) = 780
lngItems(18) = 780
lngItems(19) = 786
lngItems(20) = 996
lngItems(21) = 996
lngItems(22) = 1074
'calculate lower and upper bounds
' * calculate target = sum(lngItems)/4
' * if the largest item is > target, it should probably be the upper bound
' * otherwise, use the range as target +/- SQRT(target)
'
'initialize the sizes and lb arrays
Dim sizes() As Integer '= {118}
Dim lb() As Integer '= {3337}
Dim Target As Single, LowerBound As Integer, UpperBound As Integer
Target = lngItems.Sum / 4
LowerBound = Target - Math.Sqrt(Target)
UpperBound = Target + Math.Sqrt(Target)
ReDim lb(0)
ReDim sizes(0)
lb(0) = LowerBound
sizes(0) = UpperBound - LowerBound + 1
Dim CandidateSums As Array = Array.CreateInstance(GetType(Collection), sizes, lb)
For lngLoop = CandidateSums.GetLowerBound(0) To CandidateSums.GetUpperBound(0)
CandidateSums(lngLoop) = New Collection
Next
For lngEnumerate = (2 ^ 23) - 1 To 1 Step -1
lngSum = SumItStatic(lngEnumerate, lngItems, UpperBound + 1)
Select Case lngSum
Case LowerBound To UpperBound
CandidateSums(lngSum).Add(lngLoop)
lngCandidateCount = lngCandidateCount + 1
End Select
Next
'For lngLoop = CandidateSums.GetLowerBound(0) To CandidateSums.GetUpperBound(0)
' Debug.Print(lngLoop & vbTab & CandidateSums(lngLoop).count.ToString)
'Next
'Count total candidate sums
'lngSum = 0
'For lngLoop = LowerBound To UpperBound
' lngSum = lngSum + CandidateSums(lngLoop).Count
'Next
'NOTE: the following array is one larger than requred
ReDim lngIndexedSums(lngCandidateCount) 'was lngSum
Dim lngIndexedPosition As Long 'Current position to store next item
Dim lngTarget, lngLowerTarget, lngUpperTarget As Long
Dim lngLowerTotal, lngUpperTotal As Long
Dim lngLowerValue, lngUpperValue As Long
Dim lngItemSumTotal As Long
For lngLoop = 0 To UBound(lngItems)
lngItemSumTotal = lngItemSumTotal + lngItems(lngLoop)
Next
Select Case lngItemSumTotal Mod 4
Case 0 'exact integer
lngTarget = lngItemSumTotal / 4
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget + 1
Case 1 '.25
lngTarget = Math.Round(lngItemSumTotal / 4, 0)
lngLowerTarget = lngTarget
lngUpperTarget = lngTarget + 1
Case 2 '.5
lngTarget = 0
lngLowerTarget = Int(lngItemSumTotal / 4)
lngUpperTarget = lngLowerTarget + 1
Case 3 '.75
lngTarget = Math.Round(lngItemSumTotal / 4, 0)
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget
End Select
'Debug.Print "MOD:" & Str(lngItemSumTotal Mod 4)
'Debug.Print "Target: " & Str(lngTarget)
'Debug.Print "LowerTarget: " & Str(lngLowerTarget)
'Debug.Print "UpperTarget: " & Str(lngUpperTarget)
Dim lngLowerMergePosition, lngUpperMergePosition As Long
lngIndexedPosition = 0
Do While lngTarget <> -1
If lngTarget = lngLowerTarget Or lngTarget = lngUpperTarget Then
'MOD 1 or 3 so add all values from single target
For lngLoop = 1 To CandidateSums(lngTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
'Alternate to next target
If lngTarget = lngLowerTarget Then
lngLowerTarget = lngTarget - 1
If lngUpperTarget <= 3454 Then
lngTarget = lngUpperTarget
Else
If lngLowerTarget >= 3337 Then
lngTarget = lngLowerTarget
Else
lngTarget = -1
End If
End If
Else
lngUpperTarget = lngTarget + 1
If lngLowerTarget >= 3337 Then
lngTarget = lngLowerTarget
Else
If lngUpperTarget <= 3454 Then
lngTarget = lngUpperTarget
Else
lngTarget = -1
End If
End If
End If
Else
'MOD 0 or 2
If lngTarget > 0 Then 'MOD 0 so add exact target values first
For lngLoop = 1 To CandidateSums(lngTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
lngTarget = 0 'Start merging
End If
'Merge largest items from lower & upper target groups
lngLowerMergePosition = 1
lngUpperMergePosition = 1
lngLowerTotal = CandidateSums(lngLowerTarget).Count
lngUpperTotal = CandidateSums(lngUpperTarget).Count
Do While lngLowerMergePosition <= lngLowerTotal And _
lngUpperMergePosition <= lngUpperTotal
lngLowerValue = CandidateSums(lngLowerTarget).Item(lngLowerMergePosition)
lngUpperValue = CandidateSums(lngUpperTarget).Item(lngUpperMergePosition)
If lngLowerValue >= lngUpperValue Then
lngIndexedSums(lngIndexedPosition) = lngLowerValue
lngLowerMergePosition = lngLowerMergePosition + 1
Else
lngIndexedSums(lngIndexedPosition) = lngUpperValue
lngUpperMergePosition = lngUpperMergePosition + 1
End If
lngIndexedPosition = lngIndexedPosition + 1
Loop
If lngLowerMergePosition <= lngLowerTotal Then
'Add remaining lower target values
For lngLoop = lngLowerMergePosition To CandidateSums(lngLowerTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngLowerTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
If lngUpperMergePosition <= lngUpperTotal Then
'Add remaining upper target values
For lngLoop = lngUpperMergePosition To CandidateSums(lngUpperTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngUpperTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
'Determine next upper/lower targets
lngLowerTarget = lngLowerTarget - 1
lngUpperTarget = lngUpperTarget + 1
If lngLowerTarget < 3337 Or lngUpperTarget > 3454 Then
If lngLowerTarget < 3337 Then
If lngUpperTarget <= 3454 Then
'Upper target(s) still exist so add values
lngTarget = lngUpperTarget
Else
'Both outside limits so exit loop
lngTarget = -1
End If
Else
lngTarget = lngLowerTarget
End If
End If
End If
Loop
End Sub
Function SumItStatic(ByVal parmMask As Long, ByRef parmItems() As Long, ByVal parmSumLimit As Long) As Long
Static lngPower() As Long
Static IsInitialized As Boolean
Dim lngLoop As Long
Dim lngSum As Long
Dim lngUbound As Long
lngUbound = UBound(parmItems)
If IsInitialized Then
Else
ReDim lngPower(0 To lngUbound)
For lngLoop = 0 To lngUbound
lngPower(lngLoop) = 2 ^ lngLoop
Next
IsInitialized = True
End If
For lngLoop = lngUbound To 0 Step -1
If (parmMask And lngPower(lngLoop)) <> 0 Then
lngSum = lngSum + parmItems(lngLoop)
If lngSum > parmSumLimit Then
SumItStatic = lngSum
Exit Function
End If
End If
Next
SumItStatic = lngSum
End Function
End Module
Option Explicit On
Module Module1
Public lngIndexedSums() As Long
Sub Main()
Dim Groups() As String
Dim lngItems(0 To 30) As Long
Dim lngPower(0 To 30) As Long
Dim lngEnumerate As Long
Dim lngLoop As Integer
Dim lngSum As Integer
Dim lngCandidateCount As Integer
For lngLoop = 0 To 30
lngPower(lngLoop) = 2 ^ lngLoop
Next
lngItems(0) = 124
lngItems(1) = 170
lngItems(2) = 210
lngItems(3) = 296
lngItems(4) = 330
lngItems(5) = 400
lngItems(6) = 476
lngItems(7) = 492
lngItems(8) = 522
lngItems(9) = 544
lngItems(10) = 564
lngItems(11) = 570
lngItems(12) = 650
lngItems(13) = 662
lngItems(14) = 686
lngItems(15) = 724
lngItems(16) = 750
lngItems(17) = 780
lngItems(18) = 780
lngItems(19) = 786
lngItems(20) = 996
lngItems(21) = 996
lngItems(22) = 1074
lngItems(23) = 1079
lngItems(24) = 1083
lngItems(25) = 1239
lngItems(26) = 1287
lngItems(27) = 1391
lngItems(28) = 1396
lngItems(29) = 1412
lngItems(30) = 1457
For i As Integer = 0 To lngItems.GetUpperBound(0)
lngSum += lngItems(i)
Next
'calculate lower and upper bounds
' * calculate target = sum(lngItems)/4
' * if the largest item is > target, it should probably be the upper bound
' * otherwise, use the range as target +/- SQRT(target)
'
'initialize the sizes and lb arrays
Dim sizes() As Integer '= {118}
Dim lb() As Integer '= {3337}
Dim Target As Single, LowerBound As Integer, UpperBound As Integer
'Target = lngItems.lngItems.lngItems.Sum / 4
Target = lngSum / 4
LowerBound = Target - Math.Sqrt(Target)
UpperBound = Target + Math.Sqrt(Target)
Console.WriteLine("Target: " + Target.ToString)
Console.WriteLine("LowerBound: " + LowerBound.ToString)
Console.WriteLine("UpperBound: " + UpperBound.ToString)
Console.WriteLine()
ReDim lb(0)
ReDim sizes(0)
lb(0) = LowerBound
sizes(0) = UpperBound - LowerBound + 1
Dim CandidateSums As Array = Array.CreateInstance(GetType(Collection), sizes, lb)
For lngLoop = CandidateSums.GetLowerBound(0) To CandidateSums.GetUpperBound(0)
CandidateSums(lngLoop) = New Collection
Next
For lngEnumerate = (2 ^ 31) - 1 To 1 Step -1
lngSum = SumItStatic(lngEnumerate, lngItems, UpperBound + 1)
Select Case lngSum
Case LowerBound To UpperBound
CandidateSums(lngSum).Add(lngLoop)
lngCandidateCount = lngCandidateCount + 1
Console.CursorLeft = 0
Console.CursorTop = 4
Console.Write("Total Candidates: " + lngCandidateCount.ToString)
End Select
Next
'For lngLoop = CandidateSums.GetLowerBound(0) To CandidateSums.GetUpperBound(0)
' Debug.Print(lngLoop & vbTab & CandidateSums(lngLoop).count.ToString)
'Next
'Count total candidate sums
'lngSum = 0
'For lngLoop = LowerBound To UpperBound
' lngSum = lngSum + CandidateSums(lngLoop).Count
'Next
'NOTE: the following array is one larger than requred
ReDim lngIndexedSums(lngCandidateCount) 'was lngSum
Dim lngIndexedPosition As Long 'Current position to store next item
Dim lngTarget, lngLowerTarget, lngUpperTarget As Long
Dim lngLowerTotal, lngUpperTotal As Long
Dim lngLowerValue, lngUpperValue As Long
Dim lngItemSumTotal As Long
For lngLoop = 0 To UBound(lngItems)
lngItemSumTotal = lngItemSumTotal + lngItems(lngLoop)
Next
Select Case lngItemSumTotal Mod 4
Case 0 'exact integer
lngTarget = lngItemSumTotal / 4
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget + 1
Case 1 '.25
lngTarget = Math.Round(lngItemSumTotal / 4, 0)
lngLowerTarget = lngTarget
lngUpperTarget = lngTarget + 1
Case 2 '.5
lngTarget = 0
lngLowerTarget = Int(lngItemSumTotal / 4)
lngUpperTarget = lngLowerTarget + 1
Case 3 '.75
lngTarget = Math.Round(lngItemSumTotal / 4, 0)
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget
End Select
'Debug.Print "MOD:" & Str(lngItemSumTotal Mod 4)
'Debug.Print "Target: " & Str(lngTarget)
'Debug.Print "LowerTarget: " & Str(lngLowerTarget)
'Debug.Print "UpperTarget: " & Str(lngUpperTarget)
Dim lngLowerMergePosition, lngUpperMergePosition As Long
lngIndexedPosition = 0
Do While lngTarget <> -1
If lngTarget = lngLowerTarget Or lngTarget = lngUpperTarget Then
'MOD 1 or 3 so add all values from single target
For lngLoop = 1 To CandidateSums(lngTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
'Alternate to next target
If lngTarget = lngLowerTarget Then
lngLowerTarget = lngTarget - 1
If lngUpperTarget <= 3454 Then
lngTarget = lngUpperTarget
Else
If lngLowerTarget >= 3337 Then
lngTarget = lngLowerTarget
Else
lngTarget = -1
End If
End If
Else
lngUpperTarget = lngTarget + 1
If lngLowerTarget >= 3337 Then
lngTarget = lngLowerTarget
Else
If lngUpperTarget <= 3454 Then
lngTarget = lngUpperTarget
Else
lngTarget = -1
End If
End If
End If
Else
'MOD 0 or 2
If lngTarget > 0 Then 'MOD 0 so add exact target values first
For lngLoop = 1 To CandidateSums(lngTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
lngTarget = 0 'Start merging
End If
'Merge largest items from lower & upper target groups
lngLowerMergePosition = 1
lngUpperMergePosition = 1
lngLowerTotal = CandidateSums(lngLowerTarget).Count
lngUpperTotal = CandidateSums(lngUpperTarget).Count
Do While lngLowerMergePosition <= lngLowerTotal And _
lngUpperMergePosition <= lngUpperTotal
lngLowerValue = CandidateSums(lngLowerTarget).Item(lngLowerMergePosition)
lngUpperValue = CandidateSums(lngUpperTarget).Item(lngUpperMergePosition)
If lngLowerValue >= lngUpperValue Then
lngIndexedSums(lngIndexedPosition) = lngLowerValue
lngLowerMergePosition = lngLowerMergePosition + 1
Else
lngIndexedSums(lngIndexedPosition) = lngUpperValue
lngUpperMergePosition = lngUpperMergePosition + 1
End If
lngIndexedPosition = lngIndexedPosition + 1
Loop
If lngLowerMergePosition <= lngLowerTotal Then
'Add remaining lower target values
For lngLoop = lngLowerMergePosition To CandidateSums(lngLowerTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngLowerTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
If lngUpperMergePosition <= lngUpperTotal Then
'Add remaining upper target values
For lngLoop = lngUpperMergePosition To CandidateSums(lngUpperTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngUpperTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
'Determine next upper/lower targets
lngLowerTarget = lngLowerTarget - 1
lngUpperTarget = lngUpperTarget + 1
If lngLowerTarget < 3337 Or lngUpperTarget > 3454 Then
If lngLowerTarget < 3337 Then
If lngUpperTarget <= 3454 Then
'Upper target(s) still exist so add values
lngTarget = lngUpperTarget
Else
'Both outside limits so exit loop
lngTarget = -1
End If
Else
lngTarget = lngLowerTarget
End If
End If
End If
Console.CursorLeft = 0
Console.CursorTop = 5
Console.Write("Total Indexed Sums: " + lngIndexedPosition.ToString)
Loop
Console.Read()
End Sub
Function SumItStatic(ByVal parmMask As Long, ByRef parmItems() As Long, ByVal parmSumLimit As Long) As Long
Static lngPower() As Long
Static IsInitialized As Boolean
Dim lngLoop As Long
Dim lngSum As Long
Dim lngUbound As Long
lngUbound = UBound(parmItems)
If IsInitialized Then
Else
ReDim lngPower(0 To lngUbound)
For lngLoop = 0 To lngUbound
lngPower(lngLoop) = 2 ^ lngLoop
Next
IsInitialized = True
End If
For lngLoop = lngUbound To 0 Step -1
If (parmMask And lngPower(lngLoop)) <> 0 Then
lngSum = lngSum + parmItems(lngLoop)
If lngSum > parmSumLimit Then
SumItStatic = lngSum
Exit Function
End If
End If
Next
SumItStatic = lngSum
End Function
End Module
Case 2 '.5
lngTarget = 0
For lngEnumerate = (2 ^ 31) - 1 To 1 Step -1
lngSum = SumItStatic(lngEnumerate, lngItems, UpperBound + 1)
Select Case lngSum
Case LowerBound To UpperBound
CandidateSums(lngSum).Add(lngLoop)
**************CHANGED TO****************
CandidateSums(lngsum).Add(lngEnumerate)
***************************************
lngCandidateCount = lngCandidateCount + 1
End Select
Next
***************************************************
Latest Modifications:
Option Explicit On
Module Module1
Public lngIndexedSums() As Long
Sub Main()
Dim Groups() As String
Dim lngItems(0 To 30) As Long
Dim lngPower(0 To lngItems.GetUpperBound(0)) As Long
Dim lngEnumerate As Long
Dim lngLoop As Integer
Dim lngSum As Integer
Dim lngCandidateCount As Integer
For lngLoop = 0 To lngItems.GetUpperBound(0)
lngPower(lngLoop) = 2 ^ lngLoop
Next
lngItems(0) = 124
lngItems(1) = 170
lngItems(2) = 210
lngItems(3) = 296
lngItems(4) = 330
lngItems(5) = 400
lngItems(6) = 476
lngItems(7) = 492
lngItems(8) = 522
lngItems(9) = 544
lngItems(10) = 564
lngItems(11) = 570
lngItems(12) = 650
lngItems(13) = 662
lngItems(14) = 686
lngItems(15) = 724
lngItems(16) = 750
lngItems(17) = 780
lngItems(18) = 780
lngItems(19) = 786
lngItems(20) = 996
lngItems(21) = 996
lngItems(22) = 1074
lngItems(23) = 1079
lngItems(24) = 1083
lngItems(25) = 1239
lngItems(26) = 1287
lngItems(27) = 1391
lngItems(28) = 1396
lngItems(29) = 1412
lngItems(30) = 2677
For i As Integer = 0 To lngItems.GetUpperBound(0)
lngSum += lngItems(i)
Next
'calculate lower and upper bounds
' * calculate target = sum(lngItems)/4
' * if the largest item is > target, it should probably be the upper bound
' * otherwise, use the range as target +/- SQRT(target)
'
'initialize the sizes and lb arrays
Dim sizes() As Integer '= {118}
Dim lb() As Integer '= {3337}
Dim Target As Single, LowerBound As Integer, UpperBound As Integer
'Target = lngItems.lngItems.lngItems.Sum / 4
Target = lngSum / 4
LowerBound = Target - Math.Sqrt(Target)
UpperBound = Target + Math.Sqrt(Target)
Console.WriteLine("Target: " + Target.ToString)
Console.WriteLine("LowerBound: " + LowerBound.ToString)
Console.WriteLine("UpperBound: " + UpperBound.ToString)
Console.WriteLine()
ReDim lb(0)
ReDim sizes(0)
lb(0) = LowerBound
sizes(0) = UpperBound - LowerBound + 1
Dim CandidateSums As Array = Array.CreateInstance(GetType(Collection), sizes, lb)
Console.WriteLine("CandidateSums LowerBound(0): " + CandidateSums.GetLowerBound(0).ToString)
Console.WriteLine("CandidateSums UpperBound(0): " + CandidateSums.GetUpperBound(0).ToString)
For lngLoop = CandidateSums.GetLowerBound(0) To CandidateSums.GetUpperBound(0)
CandidateSums(lngLoop) = New Collection
Next
For lngEnumerate = ((2 ^ (lngItems.GetUpperBound(0) + 1))) - 1 To 1 Step -1
lngSum = SumItStatic(lngEnumerate, lngItems, UpperBound + 1)
Select Case lngSum
Case LowerBound To UpperBound
CandidateSums(lngSum).Add(lngEnumerate)
lngCandidateCount = lngCandidateCount + 1
Console.CursorLeft = 0
Console.CursorTop = 7
Console.Write("Total Candidates: " + lngCandidateCount.ToString)
End Select
Next
'For lngLoop = CandidateSums.GetLowerBound(0) To CandidateSums.GetUpperBound(0)
' Debug.Print(lngLoop & vbTab & CandidateSums(lngLoop).count.ToString)
'Next
'Count total candidate sums
'lngSum = 0
'For lngLoop = LowerBound To UpperBound
' lngSum = lngSum + CandidateSums(lngLoop).Count
'Next
'NOTE: the following array is one larger than requred
ReDim lngIndexedSums(lngCandidateCount) 'was lngSum
Dim lngIndexedPosition As Long 'Current position to store next item
Dim lngTarget, lngLowerTarget, lngUpperTarget As Long
Dim lngLowerTotal, lngUpperTotal As Long
Dim lngLowerValue, lngUpperValue As Long
Dim lngItemSumTotal As Long
For lngLoop = 0 To UBound(lngItems)
lngItemSumTotal = lngItemSumTotal + lngItems(lngLoop)
Next
Select Case lngItemSumTotal Mod 4
Case 0 'exact integer
lngTarget = lngItemSumTotal / 4
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget + 1
Case 1 '.25
lngTarget = Math.Round(lngItemSumTotal / 4, 0)
lngLowerTarget = lngTarget
lngUpperTarget = lngTarget + 1
Case 2 '.5
lngTarget = 0
lngLowerTarget = Int(lngItemSumTotal / 4)
lngUpperTarget = lngLowerTarget + 1
Case 3 '.75
lngTarget = Math.Round(lngItemSumTotal / 4, 0)
lngLowerTarget = lngTarget - 1
lngUpperTarget = lngTarget
End Select
'Debug.Print "MOD:" & Str(lngItemSumTotal Mod 4)
'Debug.Print "Target: " & Str(lngTarget)
'Debug.Print "LowerTarget: " & Str(lngLowerTarget)
'Debug.Print "UpperTarget: " & Str(lngUpperTarget)
Dim lngLowerMergePosition, lngUpperMergePosition As Long
lngIndexedPosition = 0
Do While lngTarget <> -1
If lngTarget = lngLowerTarget Or lngTarget = lngUpperTarget Then
'MOD 1 or 3 so add all values from single target
Console.CursorLeft = 0
Console.CursorTop = 9
'Console.Write("lngLoop: " + lngLoop.ToString)
Console.Write("CandidateSums(" + lngTarget.ToString + ") Count: " + CandidateSums(lngTarget).count.ToString)
For lngLoop = 1 To CandidateSums(lngTarget).Count
'Console.CursorLeft = 0
'Console.CursorTop = 6
'Console.Write("lngLoop: " + lngLoop.ToString)
'Console.Write("CandidateSums(" + lngTarget.ToString + ") Count: " + CandidateSums(lngTarget).count.ToString)
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
'Alternate to next target
If lngTarget = lngLowerTarget Then
lngLowerTarget = lngTarget - 1
If lngUpperTarget <= UpperBound Then
lngTarget = lngUpperTarget
Else
If lngLowerTarget >= LowerBound Then
lngTarget = lngLowerTarget
Else
lngTarget = -1
End If
End If
Else
lngUpperTarget = lngTarget + 1
If lngLowerTarget >= LowerBound Then
lngTarget = lngLowerTarget
Else
If lngUpperTarget <= UpperBound Then
lngTarget = lngUpperTarget
Else
lngTarget = -1
End If
End If
End If
Else
'MOD 0 or 2
If lngTarget > 0 Then 'MOD 0 so add exact target values first
For lngLoop = 1 To CandidateSums(lngTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
lngTarget = 0 'Start merging
End If
'Merge largest items from lower & upper target groups
lngLowerMergePosition = 1
lngUpperMergePosition = 1
lngLowerTotal = CandidateSums(lngLowerTarget).Count
lngUpperTotal = CandidateSums(lngUpperTarget).Count
Do While lngLowerMergePosition <= lngLowerTotal And _
lngUpperMergePosition <= lngUpperTotal
lngLowerValue = CandidateSums(lngLowerTarget).Item(lngLowerMergePosition)
lngUpperValue = CandidateSums(lngUpperTarget).Item(lngUpperMergePosition)
If lngLowerValue >= lngUpperValue Then
lngIndexedSums(lngIndexedPosition) = lngLowerValue
lngLowerMergePosition = lngLowerMergePosition + 1
Else
lngIndexedSums(lngIndexedPosition) = lngUpperValue
lngUpperMergePosition = lngUpperMergePosition + 1
End If
lngIndexedPosition = lngIndexedPosition + 1
Loop
If lngLowerMergePosition <= lngLowerTotal Then
'Add remaining lower target values
For lngLoop = lngLowerMergePosition To CandidateSums(lngLowerTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngLowerTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
If lngUpperMergePosition <= lngUpperTotal Then
'Add remaining upper target values
For lngLoop = lngUpperMergePosition To CandidateSums(lngUpperTarget).Count
lngIndexedSums(lngIndexedPosition) = CandidateSums(lngUpperTarget).Item(lngLoop)
lngIndexedPosition = lngIndexedPosition + 1
Next
End If
'Determine next upper/lower targets
lngLowerTarget = lngLowerTarget - 1
lngUpperTarget = lngUpperTarget + 1
If lngLowerTarget < LowerBound Or lngUpperTarget > UpperBound Then
If lngLowerTarget < LowerBound Then
If lngUpperTarget <= UpperBound Then
'Upper target(s) still exist so add values
lngTarget = lngUpperTarget
Else
'Both outside limits so exit loop
lngTarget = -1
End If
Else
lngTarget = lngLowerTarget
End If
End If
End If
Console.CursorLeft = 0
Console.CursorTop = 8
Console.Write("Total Indexed Sums: " + lngIndexedPosition.ToString)
Loop
Console.Read()
End Sub
Function SumItStatic(ByVal parmMask As Long, ByRef parmItems() As Long, ByVal parmSumLimit As Long) As Long
Static lngPower() As Long
Static IsInitialized As Boolean
Dim lngLoop As Long
Dim lngSum As Long
Dim lngUbound As Long
lngUbound = UBound(parmItems)
If IsInitialized Then
Else
ReDim lngPower(0 To lngUbound)
For lngLoop = 0 To lngUbound
lngPower(lngLoop) = 2 ^ lngLoop
Next
IsInitialized = True
End If
For lngLoop = lngUbound To 0 Step -1
If (parmMask And lngPower(lngLoop)) <> 0 Then
lngSum = lngSum + parmItems(lngLoop)
If lngSum > parmSumLimit Then
SumItStatic = lngSum
Exit Function
End If
End If
Next
SumItStatic = lngSum
End Function
End Module
(4,12,13) => 29
(5,11,12) => 28
(8,10,11) => 29
(42) => 42
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.