Alternately mix DATA in MS EXCEL - algorithm

I have one csv file which contains 10.000 rows.
The 2.000 rows have the value "EXPL_1".
The 3.000 rows have the value "EXPL_2".
The 2.500 rows have the value "EXPL_3".
The 1.500 rows have the value "EXPL_4".
The 2.000 rows have the value "EXPL_5".
I am searching a function which will mix (re-sort) alternately the values and will continue to mix them until to finish.
So the final result will be something like:
EXPL_1,
EXPL_2,
EXPL_3,
EXPL_4,
EXPL_5,
EXPL_1,
EXPL_2,
EXPL_3,
EXPL_4,
EXPL_5,
.......... (x times repeat)
EXPL_1,
EXPL_2,
EXPL_3,
EXPL_5, (*EXPL_4 values finished but continue to alternately mix the rest)
*The values are sorted by name (1st all EXPL_1, 2nd all EXPL_2 etc)
*Maybe in the future will appear more values.
*I know how many values I have in the list.

This code adds "manually" the values to the sheet, based on the quantity of the values. So if there are less values of some type, it will leave blank spaces. I used the cells on the speardsheet, but you can make operations on the array with the same logic, instead of creating a non contiguous range, you can add values to the array index using For loop Step
Dim ws As Worksheet
Dim one_rng As Range
Dim a1(), a2(), i As Long, ub As Long
Set ws = ThisWorkbook.Worksheets(1)
'Insert the number of values
For n = 1 To 5
If n = 1 Then
n_array = 20 'insert number of valuer for EXPL_1
ElseIf n = 2 Then
n_array = 30 'insert number of valuer for EXPL_2
ElseIf n = 3 Then
n_array = 25 'insert number of valuer for EXPL_3
ElseIf n = 4 Then
n_array = 15 'insert number of valuer for EXPL_4
ElseIf n = 5 Then
n_array = 20 'insert number of valuer for EXPL_5
End If
ReDim a1(1 To 1, 1 To n_array) As Variant
For i = 1 To n_array
a1(1, i) = CStr("EXPL_" & n)
Next i
ub = UBound(a1, 2)
ReDim a2(1 To ub, 1 To 1) 'resize a2 ("right" shape) to match a1
' "flip" the a1 array into a2
For i = 1 To ub
a2(i, 1) = a1(1, i)
Next i
For i = 5 + n To (5 + n) * (n_array - 1) Step 5
If i = (5 + n) Then Set one_rng = ws.Range("B" & n)
Set new_rng = ws.Range("B" & i)
Set one_rng = Union(one_rng, new_rng)
Next i
Debug.Print one_rng.Address 'Verify the Range
one_rng = a2
Next n
If it is desired to delete the blank spaces, some changes can be done.
You can .Autofilter for blank values on the range used (firstrow to last row) and then delete them.
Sub DeleteBlankRows()
Range("B:B").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
And after create an array and add the range to the array.
CODE EXPLANATION
Loop 5 times for the five types of EXPL_
For n = 1 To 5
Next n
Insert number of values to create array for each type
If n = 1 Then
n_array = 20 'insert number of valuer for EXPL_1
ElseIf n = 2 Then
n_array = 30 'insert number of valuer for EXPL_2
ElseIf n = 3 Then
n_array = 25 'insert number of valuer for EXPL_3
ElseIf n = 4 Then
n_array = 15 'insert number of valuer for EXPL_4
ElseIf n = 5 Then
n_array = 20 'insert number of valuer for EXPL_5
End If
Create Array
ReDim a1(1 To 1, 1 To n_array) As Variant
For i = 1 To n_array
a1(1, i) = CStr("EXPL_" & n)
Next i
ub = UBound(a1, 2)
ReDim a2(1 To ub, 1 To 1) 'resize a2 ("right" shape) to match a1
' "flip" the a1 array into a2
For i = 1 To ub
a2(i, 1) = a1(1, i)
Next i
Create non contiguous Range skipping 5 rows with the same number of rows as the elements of the array
For i = 5 + n To (5 + n) * (n_array - 1) Step 5
If i = (5 + n) Then Set one_rng = ws.Range("B" & n)
Set new_rng = ws.Range("B" & i)
Set one_rng = Union(one_rng, new_rng)
Next i
Insert array to range
one_rng = a2

Do you 'need' vba or can you use excel-standard methods?
If the later the easiest way in my opinion is the following:
Lets say your EXPL_1 etc. is from A1 to A....
Insert a column B and enter =countif($A$1:A1;A1) in B1.
Copy that formula down until the end of column A.
Sort your complete data by column B asc and column A asc
done :)
If you want to do it with vba you can use the same way with code:
Sub Mix_it()
Columns(2).Insert
Range(Range("B1"), Range("A" & Rows.Count).End(xlUp).Offset(0, 1)).Formula = "=COUNTIF($A$1:A1,A1)"
Range(Range("X1"), Range("A" & Rows.Count).End(xlUp)).Sort Range("B1"), xlAscending, Range("A1"), , xlAscending ' change 'X' to last column
Columns(2).Delete
End Sub

Sub MixData()
Dim arr(5) As Long 'IF expl_5 is highest - increase as necessary
Dim r As Range
Dim x As Integer
ActiveSheet.Columns(1).Insert
Set r = Range("A1")
Do
x = Val(Mid(r.Offset(0, 1), 6, 1))
arr(x) = arr(x) + 1
r.Value = arr(x)
Set r = r.Offset(1, 0)
Loop Until r.Offset(0, 1) = ""
ActiveSheet.UsedRange.Sort key1:=Range("a1")
ActiveSheet.Columns("A").Delete
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim EXPL_1 As Variant
EXPL_1 = Array("EXPL_1", "EXPL_1", "EXPL_1", "EXPL_1") 'For you it should store the csv content
Dim EXPL_2 As Variant
EXPL_2 = Array("EXPL_2", "EXPL_2", "EXPL_2")
Dim EXPL_3 As Variant
EXPL_3 = Array("EXPL_3", "EXPL_3")
Dim EXPL_4 As Variant
EXPL_4 = Array("EXPL_4")
Dim intCounter As Integer
intCounter = 0 'is our array index
Dim valueInserted As Boolean
valueInserted = False 'With this var we check if any value got inserted
Do
valueInserted = False 'We reset it here so we dont run in an endless loop
'Here we check if the array contains anything if not we just ignore that array until the others finished
If UBound(EXPL_1) >= intCounter Then
Debug.Print (EXPL_1(intCounter)) 'Write this row
valueInserted = True
End If
If UBound(EXPL_2) >= intCounter Then
Debug.Print (EXPL_2(intCounter)) 'Write this row
valueInserted = True
End If
If UBound(EXPL_3) >= intCounter Then
Debug.Print (EXPL_3(intCounter)) 'Write this row
valueInserted = True
End If
If UBound(EXPL_4) >= intCounter Then
Debug.Print (EXPL_4(intCounter)) 'Write this row
valueInserted = True
End If
If valueInserted = False Then
'If we didnĀ“t inserted any value we exit the loop
Exit Do
End If
intCounter = intCounter + 1
Loop
End Sub
This can give you an idea how it would work. You sure will have to put some effort to seperate your CSV File in the 4 array but it should be done in some minutes. Hope it helps you.
Edit: Its now an working example it prints
EXPL_1
EXPL_2
EXPL_3
EXPL_4
EXPL_1
EXPL_2
EXPL_3
EXPL_1
EXPL_2
EXPL_1

Related

iF Then Else code - how to make this run faster? VBA

I have a simple code which takes a long time to run. I was wondering if there is any way to make this run faster? Maybe this part (Cells(i, "U").Value = Cells(n, "X").Value) should not be used 2 times! Thanks!
For n = 3 To time_frame + 3
For i = 3 To 1002
If (Cells(i, "U").Value = Cells(n, "X").Value) And (Bed_in_use < 24) And Wait_L > 0 Then
Wait_L = Wait_L - (24 - Bed_in_use)
ElseIf (Cells(i, "U").Value = Cells(n, "X").Value) And (Bed_in_use < 24) And Wait_L <= 0 Then
Bed_in_use = Bed_in_use + 1
End If
Next i
Next n
MsgBox "The number of bed in use is " & Bed_in_use & ". There are " & Wait_L & " patients in the waiting list."
End Sub
Couple things will speed this up - The first was mentioned in the comments by #jcarroll, pulling the cells you need into an array and using that instead of making repeated calls to Cells.
The second is what you mentioned, structuring your If statements in a way that
you aren't making the same comparisons twice. For example, this has to be true for either condition...
Cells(i, "U").Value = Cells(n, "X").Value
...and this always has to be true:
Bed_in_use < 24
After Bed_in_use is 24 (or higher), you can exit out of the loop because you'll never satisfy either the If or the ElseIf statement. I'd re-roll it into something like this:
Dim values() As Variant
values = ActiveSheet.UsedRange '...or whatever Range you need.
For n = 3 To time_frame + 3
If Bed_in_use >= 24 Then Exit For
For i = 3 To 1002
If Bed_in_use >= 24 Then Exit For
If values(i, 21).Value = values(n, 24).Value Then
If Wait_L > 0 Then
Wait_L = Wait_L - (24 - Bed_in_use)
Else
Bed_in_use = Bed_in_use + 1
End If
End If
Next i
Next n
I'm not totally sure what your code is trying to do. But here is a sample of how you would compare two lists, and keep track of the total matches.
Sub test()
Dim arrayU() As Variant
Dim arrayX() As Variant
Dim LrowU As Integer
Dim LrowX As Integer
Dim i As Integer
Dim j As Integer
Dim bed_in_use As Integer
LrowU = Columns(21).Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LrowX = Columns(24).Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ReDim arrayU(1 To LrowU)
ReDim arrayX(1 To LrowX)
For i = 1 To LrowU
arrayU(i) = Cells(i, 21)
Next i
i = 1
For i = 1 To LrowX
arrayX(i) = Cells(i, 24)
Next i
i = 1
j = 1
For i = 1 To LrowX
For j = 1 To LrowU
If arrayX(i) = arrayU(j) Then bed_in_use = bed_in_use + 1
Next j
Next i
MsgBox (bed_in_use)
End Sub

An algorithm for iteration over all values in a column of a table

I am looking for a simple algorithm which works on the following table:
In the first column you see the constraints. The second column should be used by the algorithm to output the iterations, which should be done like this:
0 0 0
0 0 1
........
0 0 29
0 1 0
........
0 1 29
0 2 0
0 2 1
........
........
27 9 29
28 0 0
........
........
28 9 29
Currently I have the following code:
Dim wksSourceSheet As Worksheet
Set wksSourceSheet = Worksheets("Solver")
Dim lngLastRow As Long
Dim lngLastColumn As Long
With wksSourceSheet
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
lngLastColumn = IIf(IsEmpty(.Cells(1, .Columns.Count)), _
.Cells(1, .Columns.Count).End(xlToLeft).Column, .Columns.Count)
Dim intRowOuter As Integer
Dim intRowInner As Integer
For intRowOuter = 2 To lngLastRow
.Cells(intRowOuter, lngLastColumn).Value = 0
Next intRowOuter
For intRowOuter = lngLastRow To 2 Step -1
For intRowInner = lngLastRow To intRowOuter Step -1
Dim constraint As Integer
Dim intConstraintCounter As Integer
intConstraint = .Cells(intRowInner, 1)
For intConstraintCounter = 1 To intConstraint
.Cells(intRowInner, lngLastColumn).Value = intConstraintCounter
Next intStampCounter
Next intRowInner
Next intRowOuter
End With
This might be a right approach but something is incorrect. I'm unfortunately stuck so I would appreciate some help on fixing this.
Solution
I would suggest using one array to store the constraints and one to represent the counter.
Dim MaxNum() As Long
Dim myCounter() As Long
ReDim MaxNum(1 To NumDigits)
ReDim myCounter(1 To NumDigits)
Next you need to initialize MaxNum. This will probably involve looping through the cells containing the constraints. Something like:
Dim constraintRange As Range
Dim i As integer
Set constraintRange = wksSourceSheet.Range("A2:A4")
For i = 1 to numDigits
MaxNum(i) = constraintRange.Cells(i,1).Value
Next i
Now we just need to write an increment counter function! The idea is pretty simple we just go from the least significant digit to the most significant. We increment the LSD and, if there is overflow we set it to 0 and then add 1 to the next digit. It looks like this:
Sub IncrNum(ByRef myNum() As Long, ByRef MaxNum() As Long)
Dim i As Integer
For i = LBound(myNum) To UBound(myNum)
myNum(i) = myNum(i) + 1
If myNum(i) > MaxNum(i) Then 'Overflow!
myNum(i) = 0 'Reset digit to 0 and continue
Else
Exit For 'No overflow so we can just exit
End If
Next i
End Sub
Which is just one for-loop! I think this will be the cleanest solution :)
NOTE: To use this function you would simply do IncrNum(myCounter, MaxNum). Which would change the value of myCounter to the next in the sequence. From here you can paste to a range by doing dstRange = myCounter.
Testing
In my own tests I used a while loop to print out all of the values. It looked something like this:
Do While Not areEqual(MaxNum, myCounter)
Call IncrNum(myCounter,MaxNum)
outRange = myCounter
Set outRange = outRange.Offset(1, 0)
Loop
areEqual is just a function which returns true if the parameters contain the same values. If you like I can provide my code otherwise I will leave it out to keep my answer as on track as it can be.
Maybe something like this can be modified to fit your needs. It simulates addition with carry:
Sub Clicker(MaxNums As Variant)
Dim A As Variant
Dim i As Long, j As Long, m As Long, n As Long
Dim sum As Long, carry As Long
Dim product As Long
m = LBound(MaxNums)
n = UBound(MaxNums)
product = 1
For i = m To n
product = product * (1 + MaxNums(i))
Next i
ReDim A(1 To product, m To n)
For j = m To n
A(1, j) = 0
Next j
For i = 2 To product
carry = 1
For j = n To m Step -1
sum = A(i - 1, j) + carry
If sum > MaxNums(j) Then
A(i, j) = 0
carry = 1
Else
A(i, j) = sum
carry = 0
End If
Next j
Next i
Range(Cells(1, 1), Cells(product, n - m + 1)).Value = A
End Sub
Used like:
Sub test()
Clicker Array(3, 2, 2)
End Sub
Which produces:
x%10 or x Mod 10 give the remainder when x is divided by 10 so you will get the last digit of x.
Since your problem is specifically asking for each digit not to exceed 463857. You can have a counter incrementing from 000000 to 463857 and only output/use the numbers the fullfill the following condition:
IF(x%10 <= 7 AND x%100 <=57 AND x%1000 <= 857 AND x%10000 <=3857 AND x%100000 <= 63857 AND x <= 463857)
THEN //perform task.

How to count and total items in a column/sheet

I am running osx 10.9 and Excel:Mac2011. I have need to count how many of each item I have in an Excel spreadsheet.
For example:
Cat
Fish
Cat
Dog
Cat
Dog
I'm trying to get some output that would look like this
Cat Cat =3
Fish Dog =2
Cat Fish =1
Dog
Cat
Dog
the output does not need to be sorted/ordered. First come first counted/listed is fine, but i can sort the data if it needs to be.(or makes it easier)
If there is any more information I can provide to help you help me please let me know.
First and simplest, if you know that there aren't many different values in the column, you could just use countif():
=COUNTIF(A1:A6, "Cat")
Otherwise, if you've got tons of different items in a column and you want an automated solution, a VBA routine that scans the column, tallies the counts of each item, and deposits those counts in other columns seems reasonable.
Sub CountAll()
Dim searchCol, itemsCol, countCol, sheetName As String
Dim i, j, startRow As Integer
Dim aCounts() As Variant
Dim bAdded, bFound As Boolean
startRow = 1
searchCol = "A"
itemsCol = "B"
countCol = "C"
sheetName = "Sheet1"
ReDim aCounts(2, 1)
With Sheets(sheetName)
For i = 1 To .Range(searchCol & startRow).End(xlDown).Row
For j = 1 To UBound(aCounts, 2)
If (.Range(searchCol & i).Value) = aCounts(0, j) Then
bFound = True
Exit For
Else
bFound = False
End If
Next
If (bFound) Then
aCounts(1, j) = aCounts(1, j) + 1
Else
If (aCounts(1, UBound(aCounts, 2)) <> "") Then
ReDim Preserve aCounts(2, UBound(aCounts, 2) + 1)
End If
aCounts(0, UBound(aCounts, 2)) = .Range(searchCol & i).Value
aCounts(1, UBound(aCounts, 2)) = 1
End If
Next
i = 1
For i = 1 To UBound(aCounts, 2)
.Range(itemsCol & i).Value = aCounts(0, i)
.Range(countCol & i).Value = aCounts(1, i)
Next
End With
End Sub
If all your sheets are similar and you want it to run on each sheet, just change the With Sheets(sheetName) to For Each Sheet in Sheets, change End With to Next, add Sheet before each .Range, and reset the array with each iteration:
For Each Sheet In Sheets()
ReDim aCounts(2, 1)
For i = 1 To Sheet.Range(searchCol & startRow).End(xlDown).Row
For j = 1 To UBound(aCounts, 2)
If (Sheet.Range(searchCol & i).Value) = aCounts(0, j) Then
bFound = True
Exit For
Else
bFound = False
End If
Next
If (bFound) Then
aCounts(1, j) = aCounts(1, j) + 1
Else
If (aCounts(1, UBound(aCounts, 2)) <> "") Then
ReDim Preserve aCounts(2, UBound(aCounts, 2) + 1)
End If
aCounts(0, UBound(aCounts, 2)) = Sheet.Range(searchCol & i).Value
aCounts(1, UBound(aCounts, 2)) = 1
End If
Next
For i = 1 To UBound(aCounts, 2)
Sheet.Range(itemsCol & i).Value = aCounts(0, i)
Sheet.Range(countCol & i).Value = aCounts(1, i)
Next
Next
You could loop through all the sheets creating a pivot table for each one, and then copy and paste the data from each pivot table, back onto the source sheet. It's a weird way of doing it, but it will work. Here is the code:
Option Explicit
Sub PivotTableCreator()
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'Done so excel will delete the pivot table sheet without displaying a messagebox asking you if you are sure
Dim i, WSCount, LastRow As Long
WSCount = ActiveWorkbook.Worksheets.Count
Dim PTCache As PivotCache
Dim PT As PivotTable
For i = 1 To WSCount
Worksheets(i).Activate
LastRow = Range("A1000000").End(xlUp).Row
Debug.Print LastRow
Set PTCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, Range("A1", "A" & LastRow)) 'data from column A is used to create the pivot table
Worksheets.Add 'new worksheet created for pivottable
Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PTCache, TableDestination:=Range("A1"))
With PT
.PivotFields("Animals").Orientation = xlRowField 'Place whatever column A's header is here (Animals is a placeholder)
.PivotFields("Animals").Orientation = xlDataField
.DisplayFieldCaptions = False
End With
ActiveCell.CurrentRegion.Copy
Worksheets(ActiveSheet.Index + 1).Range("B2").PasteSpecial Paste:=xlPasteValues 'Paste results where you want to, I use B2 in this example
ActiveSheet.Delete 'No longer need the pivot table, so this sheet is deleted
Next
End Sub

VBA code runs two loops very slow

I have this code which runs two loops after each other. It works fine for a few thousand rows. But as the number of rows increases, the code runs significantly longer. It should loop over 100.000 rows but this will take hours and hours.
Please let me know if you see a reason why this code is taking so long
Sub BSIS()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lngRow As Long
Dim counter As Long
'Merge rows with duplicate Cells
With ActiveSheet
.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes 'change this to xlYes if your table has header cells
For lngRow = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If ActiveSheet.Cells(lngRow - 1, 1) = ActiveSheet.Cells(lngRow, 1) Then
.Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
.Rows(lngRow).Delete
End If
Next lngRow
End With
'Delete rows with negative cells
With ActiveSheet
For counter = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If ActiveSheet.Cells(counter, 4) <= 0 Then
.Rows(counter).Delete
End If
Next counter
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
one option would be copying the range of data you want to examine into an array. Do what ever data processing you want with that array, then copy the results back into the excel sheet. Here is an example:
Dim i As Integer
Dim j As Integer
Dim flagMatch As Boolean
Dim arrData2Search As Variant
Set arrData2Search = Range(Cells(1, 1), Cells(1000, 2000)).value
flagMatch = False
For j = 1 To 1000
For i = 1 To 2000
If arrData2Search (i, j)= "Target" Then
flagMatch = True
End If
Next i
Next j
The reason for slow run is that you are deleting rows one by one.
It always better to do it in single shot using UNION function
Try the below code it should work,(Tested)
Dim uni As Range
With ActiveSheet
.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes
For lngRow = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If ActiveSheet.Cells(lngRow - 1, 1) = ActiveSheet.Cells(lngRow, 1) Then
.Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
If Not uni Is Nothing Then
Set uni = Application.Union(uni, Range(.Rows(lngRow).Address))
Else
Set uni = Range(.Rows(lngRow).Address)
End If
End If
Next lngRow
uni.Delete
End With
There are a number of ways to optimize performance of one's VBA code, and a good number of articles and forums have covered the topic. For a great resource, see this.
One of the main things to remember is that every time your code interacts with the UI of Excel, it uses much more overhead than if the interaction had not occurred. That's why (to VBA Programmer's point) it's much faster to load the data to an array, perform your calculations, and then write the array back to a sheet. And that's why (to Sathish's point) it's much faster to delete all the rows at once (one interaction) compared to each one individually (multiple interactions). For more information about deleting rows, see this.
With regards to your code, is there any particular reason you need two loops?
Untested
Sub BSIS()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lngRow As Long
Dim r As Range
With ActiveSheet
.Cells(1).CurrentRegion.Sort key1:=.Cells(1), HEADER:=xlYes 'change this to xlYes if your table has header cells
'One loop:
For lngRow = .UsedRange.Rows.Count To 2 Step -1
'Merge rows with duplicate Cells
If .Cells(lngRow - 1, 1) = .Cells(lngRow, 1) Then
.Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
If r Is Nothing Then
Set r = .Cells(lgnrow, 1)
Else: Set r = Union(r, .Cells(lgnrow, 1))
End If
'Delete rows with negative cells
If .Cells(lngRow, 4) <= 0 Then
If r Is Nothing Then
Set r = .Cells(lngRow, 1)
Else: Set r = Union(r, .Cells(lgnrow, 1))
End If
Next lngRow
End With
'Delete rows
r.EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Memory and execution time reduction for algorithms

I have been asked to ask this question again and in a little different context. This is the previous post:
Filtering in VBA after finding combinations
I would like to make this code possible with 100 different variables without having excel run out of memory and reducing the execution time significantly.
The problem with the code below is that if I have 100 boxes, excel will run out of memory in the line "Result(0 To 2 ^ NumFields - 2)" ( The code works for < 10 boxes)
This is my input:
3 A B C D E ...
7.7 3 1 1 1 2 ...
5.5 2 1 2 3 3 ...
This is the code:
Function stackBox()
Dim ws As Worksheet
Dim width As Long
Dim height As Long
Dim numOfBox As Long
Dim optionsA() As Variant
Dim results() As Variant
Dim str As String
Dim outputArray As Variant
Dim i As Long, j As Long
Dim currentSymbol As String
'------------------------------------new part----------------------------------------------
Dim maxHeight As Double
Dim maxWeight As Double
Dim heightarray As Variant
Dim weightarray As Variant
Dim totalHeight As Double
Dim totalWeight As Double
'------------------------------------new part----------------------------------------------
Set ws = Worksheets("Sheet1")
With ws
'clear last time's output
height = .Cells(.Rows.Count, 1).End(xlUp).row
If height > 3 Then
.Range(.Cells(4, 1), .Cells(height, 1)).ClearContents
End If
numOfBox = .Cells(1, 1).Value
width = .Cells(1, .Columns.Count).End(xlToLeft).Column
If width < 2 Then
MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..."
Exit Function
End If
'------------------------------------new part----------------------------------------------
maxHeight = .Cells(2, 1).Value
maxWeight = .Cells(3, 1).Value
ReDim heightarray(1 To 1, 1 To width - 1)
ReDim weightarray(1 To 1, 1 To width - 1)
heightarray = .Range(.Cells(2, 2), .Cells(2, width)).Value
weightarray = .Range(.Cells(3, 2), .Cells(3, width)).Value
'------------------------------------new part----------------------------------------------
ReDim optionsA(0 To width - 2)
For i = 0 To width - 2
optionsA(i) = .Cells(1, i + 2).Value
Next i
GenerateCombinations optionsA, results, numOfBox
' copy the result to sheet only once
ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1)
Count = 0
For i = LBound(results, 1) To UBound(results, 1)
If Not IsEmpty(results(i)) Then
'rowNum = rowNum + 1
str = ""
totalHeight = 0#
totalWeight = 0#
For j = LBound(results(i), 1) To UBound(results(i), 1)
currentSymbol = results(i)(j)
str = str & currentSymbol 'results(i)(j) is the SYMBOL e.g. A, B, C
'look up box's height and weight , increment the totalHeight/totalWeight
updateParam currentSymbol, optionsA, heightarray, weightarray, totalHeight, totalWeight
Next j
If totalHeight < maxHeight And totalWeight < maxWeight Then
Count = Count + 1
outputArray(Count, 1) = str
End If
'.Cells(rowNum, 1).Value = str
End If
Next i
.Range(.Cells(4, 1), .Cells(UBound(outputArray, 1) + 3, 1)).Value = outputArray
End With
End Function
Sub updateParam(ByRef targetSymbol As String, ByRef symbolArray As Variant, ByRef heightarray As Variant, ByRef weightarray As Variant, ByRef totalHeight As Double, ByRef totalWeight As Double)
Dim i As Long
Dim index As Long
index = -1
For i = LBound(symbolArray, 1) To UBound(symbolArray, 1)
If targetSymbol = symbolArray(i) Then
index = i
Exit For
End If
Next i
If index <> -1 Then
totalHeight = totalHeight + heightarray(1, index + 1)
totalWeight = totalWeight + weightarray(1, index + 1)
End If
End Sub
Sub GenerateCombinations(ByRef AllFields() As Variant, _
ByRef Result() As Variant, ByVal numOfBox As Long)
Dim InxResultCrnt As Integer
Dim InxField As Integer
Dim InxResult As Integer
Dim i As Integer
Dim NumFields As Integer
Dim Powers() As Integer
Dim ResultCrnt() As String
NumFields = UBound(AllFields) - LBound(AllFields) + 1
ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination
ReDim Powers(0 To NumFields - 1) ' one entry per field name
' Generate powers used for extracting bits from InxResult
For InxField = 0 To NumFields - 1
Powers(InxField) = 2 ^ InxField
Next
For InxResult = 0 To 2 ^ NumFields - 2
' Size ResultCrnt to the max number of fields per combination
' Build this loop's combination in ResultCrnt
ReDim ResultCrnt(0 To NumFields - 1)
InxResultCrnt = -1
For InxField = 0 To NumFields - 1
If ((InxResult + 1) And Powers(InxField)) <> 0 Then
' This field required in this combination
InxResultCrnt = InxResultCrnt + 1
ResultCrnt(InxResultCrnt) = AllFields(InxField)
End If
Next
If InxResultCrnt = 0 Then
Debug.Print "testing"
End If
'additional logic here
If InxResultCrnt >= numOfBox Then
Result(InxResult) = Empty
Else
' Discard unused trailing entries
ReDim Preserve ResultCrnt(0 To InxResultCrnt)
' Store this loop's combination in return array
Result(InxResult) = ResultCrnt
End If
Next
End Sub
Here's a version that does all the heavy lifting in variant arrays
(Combinations logic based on this answer for This Answer by Joubarc)
This runs on a sample dataset of 100 boxes with > 40,000 returned, and in < 1 second
Notes:
Execution time rises quickly if the Max number of boxes increases (eg 4 from 100: approx 13s)
If the number of returned results exceeds 65535, the code to tranpose the array into the sheet fails (last line of the sub) If you need to handle this may results, you will need to change the way results are returned to the sheet
Sub Demo()
Dim rNames As Range
Dim rHeights As Range
Dim rWeights As Range
Dim aNames As Variant
Dim aHeights As Variant
Dim aWeights As Variant
Dim MaxNum As Long
Dim MaxHeight As Double
Dim MaxWeight As Double
' *** replace these six line with your data ranges
Set rNames = Range([F5], [F5].End(xlToRight))
Set rHeights = rNames.Offset(1, 0)
Set rWeights = rNames.Offset(2, 0)
MaxNum = [C5]
MaxHeight = [C6]
MaxWeight = [C7]
aNames = rNames
aHeights = rHeights
aWeights = rWeights
Dim Result() As Variant
Dim n As Long, m As Long
Dim i As Long, j As Long
Dim iRes As Long
Dim res As String
Dim TestCombin() As Long
Dim TestWeight As Double
Dim TestHeight As Double
Dim idx() As Long
' Number of boxes
ReDim TestCombin(0 To MaxNum - 1)
n = UBound(aNames, 2) - LBound(aNames, 2) + 1
' estimate size of result array = number of possible combinations
For m = 1 To MaxNum
i = i + Application.WorksheetFunction.Combin(n, m)
Next
ReDim Result(1 To 3, 1 To i)
' allow for from 1 to MaxNum of boxes
iRes = 1
For m = 1 To MaxNum
ReDim idx(0 To m - 1)
For i = 0 To m - 1
idx(i) = i
Next i
Do
'Test current combination
res = ""
TestWeight = 0#
TestHeight = 0#
For j = 0 To m - 1
'Debug.Print aNames(1, idx(j) + 1);
res = res & aNames(1, idx(j) + 1)
TestWeight = TestWeight + aWeights(1, idx(j) + 1)
TestHeight = TestHeight + aHeights(1, idx(j) + 1)
Next j
'Debug.Print
If TestWeight <= MaxWeight And TestHeight <= MaxHeight Then
Result(1, iRes) = res
' optional, include actual Height and Weight in result
Result(2, iRes) = TestHeight
Result(3, iRes) = TestWeight
iRes = iRes + 1
End If
' Locate last non-max index
i = m - 1
While (idx(i) = n - m + i)
i = i - 1
If i < 0 Then
'All indexes have reached their max, so we're done
Exit Do
End If
Wend
'Increase it and populate the following indexes accordingly
idx(i) = idx(i) + 1
For j = i To m - 1
idx(j) = idx(i) + j - i
Next j
Loop
Next
' Return Result to sheet
Dim rng As Range
ReDim Preserve Result(1 To 3, 1 To iRes)
' *** Adjust returnm range to suit
Set rng = [E10].Resize(UBound(Result, 2), UBound(Result, 1))
rng = Application.Transpose(Result)
End Sub

Resources