I have a list of items in column A and each of this items has 10 different values in subsequent columns. I need to create a formula (or most probably more than one formula) that would return the highest possible sum of 10 values (one from each column) with a restriction that each item can be used one time at most. I would also need an order in which those items were used. I was trying to do it in a few steps:
Step 1:
Check the highest value in column B.
Step 2:
Check the highest value in column C.
Step 3:
If this is the same item then find the second highest value for columns B and C and check which sum is higher (1st of B and second of C or other way around).
This algorithm however in rare cases gives incorrect output and the formula grows exponentially as I need to add comparison for 10 different values for each column. It would be quite bothersome if I tried to expand the number of values someday. If you see a better solution please let me know. I wouldn't mind if that would need VBA.
If you need to take a look at all combinations and come up with the best solution, then this looks like a version of the Knapsack problem or another NP-complete problem:
Image: https://xkcd.com/287/
If someone is interested in the solution of the joke above, it can be achieved with 6 nested loops, if we consider that the solution consists of maximal 6×6 elements (e.g., if there was a dessert for 1 cent, then the obvious solution for 1505 x 1 cent will not be reached:
Option Explicit
Sub TestMe()
Dim myArr As Variant
Dim myLoop As Variant
Dim targetValue As Long
Dim currentSum As Long
myArr = Array(215, 275, 335, 355, 420, 580)
targetValue = 1505
Dim cnt0&, cnt1&, cnt2&, cnt3&, cnt4&, cnt5&, cnt6&
Dim cnt As Long
For cnt0 = 0 To 5
For cnt1 = 0 To 5
For cnt2 = 0 To 5
For cnt3 = 0 To 5
For cnt4 = 0 To 5
For cnt5 = 0 To 5
currentSum = 0
Dim printableArray As Variant
printableArray = Array(cnt0, cnt1, cnt2, cnt3, cnt4, cnt5)
For cnt = LBound(myArr) To UBound(myArr)
IncrementSum printableArray(cnt), myArr(cnt), currentSum
Next cnt
If currentSum = targetValue Then
printValuesOfArray printableArray, myArr
End If
Next: Next: Next: Next: Next: Next
End Sub
Public Sub printValuesOfArray(myArr As Variant, initialArr As Variant)
Dim cnt As Long
Dim printVal As String
For cnt = LBound(myArr) To UBound(myArr)
If myArr(cnt) Then
printVal = printVal & myArr(cnt) & " * " & initialArr(cnt) & vbCrLf
End If
Next cnt
Debug.Print printVal
End Sub
Public Sub IncrementSum(ByVal multiplicator As Long, _
ByVal arrVal As Long, ByRef currentSum As Long)
currentSum = currentSum + arrVal * multiplicator
End Sub
Thus the only solution is:
1 * 215
2 * 355
1 * 580
And if you have studied more than one semester of Algorithms and somehow you hate nested loops, then the above code can be written with recursion:
Option Explicit
Sub Main()
Dim posArr As Variant
Dim iniArr As Variant
Dim tryArr As Variant
Dim cnt As Long
Dim targetVal As Long: targetVal = 1505
iniArr = Array(215, 275, 335, 355, 420, 580)
ReDim posArr(UBound(iniArr))
ReDim tryArr(UBound(iniArr))
For cnt = LBound(posArr) To UBound(posArr)
posArr(cnt) = cnt
Next cnt
EmbeddedLoops 0, posArr, tryArr, iniArr, targetVal
End Sub
Function EmbeddedLoops(index As Long, posArr As Variant, tryArr As Variant, _
iniArr As Variant, targetVal As Long)
Dim myUnit As Variant
Dim cnt As Long
If index >= UBound(posArr) + 1 Then
If CheckSum(tryArr, iniArr, targetVal) Then
For cnt = LBound(tryArr) To UBound(tryArr)
If tryArr(cnt) Then Debug.Print tryArr(cnt) & " x " & iniArr(cnt)
Next cnt
End If
Else
For Each myUnit In posArr
tryArr(index) = myUnit
EmbeddedLoops index + 1, posArr, tryArr, iniArr, targetVal
Next myUnit
End If
End Function
Public Function CheckSum(posArr, iniArr, targetVal) As Boolean
Dim cnt As Long
Dim compareVal As Long
For cnt = LBound(posArr) To UBound(posArr)
compareVal = posArr(cnt) * iniArr(cnt) + compareVal
Next cnt
CheckSum = CBool(compareVal = targetVal)
End Function
The following VBA macro assumes that the Item Name is in Column A, the Values are in Columns B to K, that Row 1 is a header, and that the Values are Long (i.e. no Decimal points)
This is an inefficient brute-force method. For 10 items, it takes about 2 minutes to calculate. For 11 items, it takes about 7.5 minutes, etc - since growth will be exponential, you will want to pare down the possible answers before you run it. (e.g. the Item for each column will be taken from the top 10 Values for that column - so, you can delete any item that doesn't appear in the top 10 for any column)
Option Explicit
Sub VeryLongBruteForceMethod()
Dim Screen As Boolean, Calc As XlCalculation, Mouse As XlMousePointer
Mouse = Application.Cursor
Application.Cursor = xlDefault
Screen = Application.ScreenUpdating
Calc = Application.Calculation
Application.Cursor = xlWait
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Row / Value for each column
Dim MaxItems(0 To 9, 0 To 1) As Long, lMaxVal As Long
Dim TestItems(0 To 9, 0 To 1) As Long, lTestVal As Long
Dim lMaxRow As Long, lTestRow As Long, bTest As Boolean
Dim lCol0 As Long, lCol1 As Long, lCol2 As Long, lCol3 As Long, lCol4 As Long
Dim lCol5 As Long, lCol6 As Long, lCol7 As Long, lCol8 As Long, lCol9 As Long
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Worksheets(1) 'First sheet in Workbook
lMaxRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Row 'Get Row for last item
lMaxVal = 0
For lCol0 = 2 To lMaxRow 'Assumes Row1 is a header
TestItems(0, 0) = lCol0 'Store row
TestItems(0, 1) = wsTarget.Cells(lCol0, 2).Value 'Store value
For lCol1 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
If lCol1 = lCol0 Then bTest = False 'Row already used in this permutation
If bTest Then
TestItems(1, 0) = lCol1 'Store row
TestItems(1, 1) = wsTarget.Cells(lCol1, 3).Value 'Store value
For lCol2 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 1
If TestItems(lTestRow, 0) = lCol2 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(2, 0) = lCol2 'Store row
TestItems(2, 1) = wsTarget.Cells(lCol2, 4).Value 'Store value
For lCol3 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 2
If TestItems(lTestRow, 0) = lCol3 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(3, 0) = lCol3 'Store row
TestItems(3, 1) = wsTarget.Cells(lCol3, 5).Value 'Store value
For lCol4 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 3
If TestItems(lTestRow, 0) = lCol4 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(4, 0) = lCol4 'Store row
TestItems(4, 1) = wsTarget.Cells(lCol4, 6).Value 'Store value
For lCol5 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 4
If TestItems(lTestRow, 0) = lCol5 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(5, 0) = lCol5 'Store row
TestItems(5, 1) = wsTarget.Cells(lCol5, 7).Value 'Store value
For lCol6 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 5
If TestItems(lTestRow, 0) = lCol6 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(6, 0) = lCol6 'Store row
TestItems(6, 1) = wsTarget.Cells(lCol6, 8).Value 'Store value
For lCol7 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 6
If TestItems(lTestRow, 0) = lCol7 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(7, 0) = lCol7 'Store row
TestItems(7, 1) = wsTarget.Cells(lCol7, 9).Value 'Store value
For lCol8 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 7
If TestItems(lTestRow, 0) = lCol8 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(8, 0) = lCol8 'Store row
TestItems(8, 1) = wsTarget.Cells(lCol8, 10).Value 'Store value
For lCol9 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 8
If TestItems(lTestRow, 0) = lCol9 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(9, 0) = lCol9 'Store row
TestItems(9, 1) = wsTarget.Cells(lCol9, 11).Value 'Store value
lTestVal = 0
'Application.StatusBar = lCol0 & "|" & lCol1 & "|" & lCol2 & "|" & lCol3 & "|" & lCol4 & "|" & lCol5 & "|" & lCol6 & "|" & lCol7 & "|" & lCol8 & "|" & lCol9
For lTestRow = 0 To 9 'Total up our Value
lTestVal = lTestVal + TestItems(lTestRow, 1)
Next lTestRow
If lTestVal > lMaxVal Then 'Compare to current Max
For lTestRow = 0 To 9 'If more, replace with new Max
MaxItems(lTestRow, 0) = TestItems(lTestRow, 0)
MaxItems(lTestRow, 1) = TestItems(lTestRow, 1)
Next lTestRow
lMaxVal = lTestVal
End If
End If
Next lCol9
End If
Next lCol8
End If
Next lCol7
End If
DoEvents ' Try not to let Excel crash on us!
Next lCol6
End If
Next lCol5
End If
Next lCol4
End If
Next lCol3
End If
Next lCol2
End If
Next lCol1
Next lCol0
'Output to a message box:
'Column 1: ItemName01 | Value01
' ...
'Column 10: ItemName10 | Value10
'Total Value | TotalValue
Dim sOutput As String
sOutput = ""
For lTestRow = 0 To 9
sOutput = sOutput & "Column " & (lTestRow + 1) & ": " & wsTarget.Cells(MaxItems(lTestRow, 0), 1).Value & " | " & MaxItems(lTestRow, 1) & vbCrLf
Next lTestRow
sOutput = sOutput & "Total Value | " & lMaxVal
MsgBox sOutput
Erase TestItems
Erase MaxItems
Application.StatusBar = False
Application.Cursor = Mouse
Application.Calculation = Calc
Application.ScreenUpdating = Screen
End Sub
Related
I used to have a table with a header row of 10 columns each labelled 1-10. I have combined some of the columns so that now my table looks like this.
0-2
3-4
5
6-7
8-9
10
Red
Orange
Yellow
Green
Blue
Black
Given a score of 5 I can use the following to find column C and get "Yellow":
Set range = Worksheets(colorScore).Range("1:1").Find(What:=Score)
But how can I extend that code to lookup a score of 3? or a score of 1?
Lookup with Intervals
It is assumed that the range contains two rows where the first row contains the lookup value (whole number) or an interval of lookup values (whole numbers) and the second row contains the return values.
Option Explicit
Sub TESTlookupRowInterval()
Dim rg As Range: Set rg = Range("A1").CurrentRegion
Dim Result As Variant
Dim i As Long
For i = -5 To 15
Result = lookupRowInterval(rg, i)
If Not IsEmpty(Result) Then
Debug.Print i, Result
End If
Next i
End Sub
' Result
' 0 Red
' 1 Red
' 2 Red
' 3 Orange
' 4 Orange
' 5 Yellow
' 6 Green
' 7 Green
' 8 Blue
' 9 Blue
' 10 Black
Function lookupRowInterval( _
rg As Range, _
ByVal LookupIndex As Long, _
Optional ByVal Delimiter As String = "-") _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count <> 2 Then Exit Function
Dim Data As Variant: Data = rg.Value
With CreateObject("Scripting.Dictionary")
Dim cInterval() As String
Dim j As Long
Dim n As Long
Dim iStart As Long
Dim iEnd As Long
Dim iTemp As Long
For j = 1 To UBound(Data, 2)
cInterval = Split(Data(1, j), Delimiter)
Select Case UBound(cInterval)
Case 0
If isLng(cInterval(0)) Then
.Item(CLng(cInterval(0))) = Data(2, j)
End If
Case 1
If isLng(cInterval(0)) And isLng(cInterval(1)) Then
iStart = CLng(cInterval(0))
iEnd = CLng(cInterval(1))
If iStart > iEnd Then ' Switch.
iTemp = iStart: iStart = iEnd: iEnd = iTemp
End If
For n = iStart To iEnd
.Item(n) = Data(2, j)
Next n
End If
End Select
Next j
If .Count = 0 Then Exit Function
lookupRowInterval = .Item(LookupIndex)
End With
End Function
Function isLng( _
CheckValue As Variant) _
As Boolean
On Error GoTo clearError
Dim Result As Long
If UBound(Split(CheckValue, ".")) = 0 Then ' Allow only whole numbers.
Result = CLng(CheckValue) ' Error if not number.
isLng = True
End If
ProcExit:
Exit Function
clearError:
Resume ProcExit
End Function
Dim numCols As Integer
Dim isRng As String
Dim colHeading As String
Dim lowNum As String
Dim highNum As String
Dim num As String
'Count the number of title row cells
numCols = Worksheets(trait).Range("1:1").End(xlToRight).Column
For i = 1 To numCols
colHeading = Worksheets(trait).Cells(1, i).Value
isRng = InStr(colHeading, "-") 'does it have a dash (is it a range)?
If isRng Then 'if it does have a dash...
lowNum = Mid(colHeading, 1, isRng - 1) 'everything before the dash
highNum = Mid(colHeading, isRng + 1) 'everything after the dash
If score >= lowNum And score <= highNum Then 'if your score is between or equal to the low and high numbers...
Debug.Print "Your score come from column " & i
End If
Else 'if it doesn't have a dash...
num = colHeading
If score = num Then
Debug.Print "Your score come from column " & i
End If
End If
Next i
Function ReturnColor(number As Integer) As String
Set Rng = Application.Intersect(Rows(1), ActiveSheet.UsedRange)
ReturnColor = "#no match#"
For Each cl In Rng
a = Split(cl, "-")
Select Case True
Case number < CInt(a(0))
Exit For
Case number = a(0)
ReturnColor = cl.Offset(1): Exit For
Case UBound(a) = 1
If number <= CInt(a(1)) Then ReturnColor = cl.Offset(1): Exit For
End Select
Next
End Function
Sub test()
Dim i As Integer
For i = -5 To 15
Debug.Print "Color for " & i & " is " & ReturnColor(i)
Next
End Sub
I have the following code:
Sub combinations()
Range("G2:G" & Range("G2").End(xlDown).Row).ClearContents
Range("H2:G" & Range("H2").End(xlDown).Row).ClearContents
Range("I2:G" & Range("I2").End(xlDown).Row).ClearContents
Range("J2:G" & Range("J2").End(xlDown).Row).ClearContents
Dim c1() As Variant
Dim c2() As Variant
Dim c3() As Variant
Dim c4() As Variant
Dim out() As Variant
Dim j As Long, k As Long, l As Long, m As Long, n As Long
Dim col1 As Range
Dim col2 As Range
Dim col3 As Range
Dim col4 As Range
Dim out1 As Range
Set col1 = Range("A2", Range("A2").End(xlDown))
Set col2 = Range("B2", Range("B2").End(xlDown))
Set col3 = Range("C2", Range("C2").End(xlDown))
Set col4 = Range("D2", Range("D2").End(xlDown))
c1 = col1
c2 = col2
c3 = col3
c4 = col4
Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4)))
out = out1
j = 1
k = 1
l = 1
m = 1
n = 1
Do While j <= UBound(c1)
Do While k <= UBound(c2)
Do While l <= UBound(c3)
Do While m <= UBound(c4)
out(n, 1) = c1(j, 1)
out(n, 2) = c2(k, 1)
out(n, 3) = c3(l, 1)
out(n, 4) = c4(m, 1)
n = n + 1
m = m + 1
Loop
m = 1
l = l + 1
Loop
l = 1
k = k + 1
Loop
k = 1
j = j + 1
Loop
out1.Value = out
End Sub
It creates all possible combination for values you put in A:A through D:D.
Example of a working table:
Header1 Header2 Header3 Header4
A1 B1 C1 D1
A2 B2 C2 D2
A3 B3 C3 D3
The only time it does not work is when one of the columns only has 1 value.
Example of a not working table:
Header1 Header2 Header3 Header4
A1 B1 C1 D1
B2 C2 D2
B3 C3 D3
I get a
Run-time error '1004;
Is there a way to fix this so that it would work for columns with 1 value as well?
This should work for you. Please note that it will work for any number of columns, not just 4, and that it will also work if any of the columns don't have full population (though each column must have at least one populated cell).
Sub tgr()
Dim ws As Worksheet
Dim rDest As Range
Dim aHeaders() As Variant
Dim aTemp() As Variant
Dim aData() As Variant
Dim aResults() As Variant
Dim vTemp As Variant
Dim ixData As Long
Dim ixResult As Long
Dim ixRow As Long
Dim ixCol As Long
Dim lMaxRows As Long
Dim lResultsBlock As Long
Dim lOverflowResults As Long
Dim bPopulated As Boolean
'Adjust these as necessary
Set ws = ActiveWorkbook.Worksheets(1) 'The worksheet that contains the table of values
Set rDest = ws.Range("G2") 'The worksheet and cell where results should be output to
lResultsBlock = 100000 'The number of rows the results array can contain before having to output results and then continuing
'Get table of values that will be used to create combinations, assume table starts in A1 and has headers
With ws.Range("A1").CurrentRegion
If .Rows.Count = 1 Then Exit Sub 'No data
If .Cells.Count = 2 Then
ReDim aHeaders(1 To 1, 1 To 1)
aHeaders(1, 1) = .Cells(1).Value
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Cells(2).Value
Else
aHeaders = .Resize(1).Value
aData = .Offset(1).Resize(.Rows.Count - 1).Value
End If
lMaxRows = UBound(aData, 1) ^ UBound(aData, 2)
ReDim aResults(1 To lResultsBlock, 1 To UBound(aData, 2))
lOverflowResults = 0
End With
'Clear previous results
ClearResults rDest
'Iterate over the table of values and create every possible combination
For ixRow = 1 To lMaxRows
'Prevent Excel from looking frozen, show a % percent complete
If (ixRow - 1) Mod 10000 = 0 Then
DoEvents
Application.StatusBar = "Processing: " & Format(ixRow / lMaxRows, "0.00%") & " completed..."
End If
'Check if this combination has any empty/blank values
bPopulated = True
ReDim aTemp(1 To UBound(aResults, 2))
For ixCol = 1 To UBound(aResults, 2)
ixData = Int(((ixRow - 1) Mod (UBound(aData, 1) ^ (UBound(aData, 2) - (ixCol - 1)))) / (UBound(aData, 1) ^ (UBound(aData, 2) - ixCol))) + 1
vTemp = aData(ixData, ixCol)
If Len(vTemp) > 0 Then
aTemp(ixCol) = vTemp
Else
'Empty/blank found, skip this combination
bPopulated = False
Exit For
End If
Next ixCol
If bPopulated Then
'No empties/blanks found in this combination, add it to results
ixResult = ixResult + 1
For ixCol = 1 To UBound(aResults, 2)
aResults(ixResult, ixCol) = aTemp(ixCol)
Next ixCol
Erase aTemp
'Output results if the results array is full
If ixResult = UBound(aResults, 1) Then OutputResults ws, rDest, aResults, ixResult, lOverflowResults, aHeaders
End If
Next ixRow
'Output results if results array is at least partially populated
If ixResult > 0 Then OutputResults ws, rDest, aResults, ixResult, lOverflowResults, aHeaders
Application.StatusBar = vbNullString
End Sub
'This will clear any previous results
Sub ClearResults(ByVal arg_rDest As Range)
Dim ws As Worksheet
arg_rDest.CurrentRegion.ClearContents
Application.DisplayAlerts = False
For Each ws In arg_rDest.Worksheet.Parent.Worksheets
If ws.Name Like "Overflow Results (*)" Then ws.Delete
Next ws
Application.DisplayAlerts = True
End Sub
'This will output the current results array to the appropriate destination, accounting for if a new sheet needs to be created and whether headers need to be provided
Sub OutputResults(ByRef arg_wsDest As Worksheet, _
ByVal arg_rDest As Range, _
ByRef arg_aResults As Variant, _
ByRef arg_ixResult As Long, _
ByRef arg_lOverflowResults As Long, _
Optional ByVal arg_aHeaders As Variant)
Dim rDest As Range
Dim lHeaderRow As Long
Dim lRowCount As Long
Dim lColCount As Long
'Check if this is the first time results are being output
If arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Row <= arg_rDest.Row Then
'This is the first time results are being output
arg_lOverflowResults = 0
'Check if headers need to be placed
If IsArray(arg_aHeaders) Then
If arg_rDest.Row = 1 Then lHeaderRow = 1 Else lHeaderRow = arg_rDest.Row - 1
With arg_wsDest.Cells(lHeaderRow, arg_rDest.Column).Resize(, UBound(arg_aHeaders, 2))
.Value = arg_aHeaders
.Font.Bold = True
End With
Set rDest = arg_wsDest.Cells(lHeaderRow + 1, arg_rDest.Column)
Else
Set rDest = arg_rDest
End If
End If
'These are used to create a new, empty results array after results are output
lRowCount = UBound(arg_aResults, 1)
lColCount = UBound(arg_aResults, 2)
'Check if there is room left in the current destination worksheet to contain all of the results
If arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Row + 1 + arg_ixResult > arg_wsDest.Rows.Count Then
'Not enough room found, create a new sheet to continue outputting results on and apply headers if necessary
arg_lOverflowResults = arg_lOverflowResults + 1
Set arg_wsDest = arg_wsDest.Parent.Worksheets.Add(AFter:=arg_wsDest)
arg_wsDest.Name = "Overflow Results (" & arg_lOverflowResults & ")"
If IsArray(arg_aHeaders) Then
With arg_wsDest.Cells(1, arg_rDest.Column).Resize(, UBound(arg_aHeaders, 2))
.Value = arg_aHeaders
.Font.Bold = True
End With
Set rDest = arg_wsDest.Cells(2, arg_rDest.Column)
Else
Set rDest = arg_wsDest.Cells(1, arg_rDest.Column)
End If
Else
'Enough room found, set destination for where results should begin
If rDest Is Nothing Then Set rDest = arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Offset(1)
End If
'Output results
rDest.Resize(arg_ixResult, UBound(arg_aResults, 2)).Value = arg_aResults
'Clear the existing results array and create a new, empty results array
Erase arg_aResults
ReDim arg_aResults(1 To lRowCount, 1 To lColCount)
arg_ixResult = 0
End Sub
Sub CreateTable()
Dim bf As Boolean
Dim aTable(), aRes()
Dim i As Long, k As Long, n As Long
With Worksheets("DOHADNÉ POLOŽKY") ' List s tabulkou, kde se hleda
i = .Cells(.Rows.Count, "A").End(xlUp).row
aTable = .Range("A1:P" & i).Value ' tabulka do pole
ReDim aRes(1 To i + 1, 1 To 1) ' velikost pole
End With
For i = 1 To UBound(aTable) ' od 1 do poctu radky tabulky
If aTable(i, 1) <> Empty Then ' kdyz neni prazdna
If aTable(i, 4) = "Depo" And aTable(i, 8) = "CZK" Then
aTable(i, 12) = aRes(i, 1): i = i + 1
End If
End If
Next i
' upload vysledku na list do sloupce J
Worksheets("List1").Range("A1").Resize(UBound(aRes), 1).Value = aRes
Range("A1").Select
ActiveCell.FormulaR1C1 = "KUK"
End Sub
Something is wrong. It has no errors, but it doesn't write value in array I think. So the result on Worksheet("List1") is just empty.
I am trying to get all row combinations of all columns (say 8 columns). The following vba macro can do that but I get an error that says data overload:
Option Explicit
Const sTitle As String = "shg Cartesian Product"
Sub CartesianProduct()
' shg 2012, 2013
' Choose one from col A, one from col B, ...
Dim rInp As Range
Dim avInp As Variant ' ragged input list
Dim nCol As Long ' # columns in list
Dim rOut As Range ' output range
Dim iCol As Long ' column index
Dim iRow As Long ' row index
Dim aiCum() As Long ' cum count of arrangements from right to left
Dim aiCnt() As Long ' count of items in each column
Dim iArr As Long ' arrangement number
Dim avOut As Variant ' output buffer
Application.ScreenUpdating = False
Set rInp = Range("rgnInp")
If VarType(rInp.Value) = vbEmpty Then
MsgBox Prompt:="No input!", _
Buttons:=vbOKOnly, _
Title:=sTitle
Exit Sub
End If
Set rInp = rInp.CurrentRegion
If rInp.Columns.Count < 2 Or rInp.Rows.Count < 2 Then
MsgBox Prompt:="Must have more than one row and more than one columns!", _
Buttons:=vbOKOnly, _
Title:=sTitle
Exit Sub
End If
With rInp
.Style = "Input"
avInp = .Value
nCol = .Columns.Count
Set rOut = .Resize(1).Offset(.Rows.Count + 1)
Range(rOut.Offset(-1, -1), Cells(Rows.Count, Columns.Count)).Clear
End With
ReDim aiCum(1 To nCol + 1)
ReDim aiCnt(1 To nCol)
aiCum(nCol + 1) = 1
For iCol = nCol To 1 Step -1
For iRow = 1 To UBound(avInp, 1)
If IsEmpty(avInp(iRow, iCol)) Then Exit For
aiCnt(iCol) = aiCnt(iCol) + 1
Next iRow
aiCum(iCol) = aiCnt(iCol) * aiCum(iCol + 1) <------ This is where it says error is
Next iCol
If aiCum(1) > Rows.Count - rOut.Row + 1 Then
MsgBox Prompt:=Format(aiCum(1), "#,##0") & _
" is too many rows!", _
Buttons:=vbOKOnly, Title:=sTitle
Exit Sub
End If
ReDim avOut(1 To aiCum(1), 1 To nCol)
For iArr = 1 To aiCum(1)
For iCol = 1 To nCol
avOut(iArr, iCol) = avInp((Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1, iCol)
Next iCol
Next iArr
With rOut.Resize(aiCum(1), nCol)
.NumberFormat = "#"
.Value = avOut
.Style = "Code"
.Cells(1, 0).Value = 1
.Cells(2, 0).Value = 2
.Cells(1, 0).Resize(2).AutoFill .Columns(0)
End With
ActiveWindow.FreezePanes = False
rOut.EntireColumn.AutoFit
ActiveSheet.UsedRange
Beep
End Sub
Is there away to adjust for this? I also want it to not bring back the same values for a row. So lets say that two columns had the exact same data. If column A has lets say Ice cream, cake, and cookies and so does Column B, I don't want Row 1 to have cookies in column B if it is already picked in Column A.
I have 100 names in one column. And next to each name in the next cell is a numerical value that the name is worth.There are 6 positions in a company that each name could potentially hold. And that is also in a cell next to each name.
So the spreadsheet looks something like this.
John Smith Lawyer $445352
Joe Doe Doctor $525222
John Doe Accountant $123192
etc....
I want excel to give me 10 people who make a combined amount between 2 and 3 million dollars. But I require that 2 of the people be doctors 2 be lawyers and 2 be accountants etc. How would I create this?
I set up sheet 1 with the following data:
Goal:
Return 10 people
Salary between 1000000 and 6000000 range
Min 2 each doc, lawyer, accountant
Run this Macro:
Sub macro()
Dim rCell As Range
Dim rRng As Range
Dim rangelist As String
Dim entryCount As Long
Dim totalnum As Long
Set rRng = Sheet1.Range("A1:A12")
Dim OccA As String
Dim OccCntA As Long
Dim OccASalmin As Long
Dim OccASalmax As Long
Dim OccB As String
Dim OccCntB As Long
Dim OccBSalmin As Long
Dim OccBSalmax As Long
Dim OccC As String
Dim OccCntC As Long
Dim OccCSalmin As Long
Dim OccCSalmax As Long
'Set total number of results to return
totalnum = 10
'Set which occupations that must be included in results
OccA = "Accountant"
OccB = "Doctor"
OccC = "Lawyer"
'Set minimum quantity of each occupation to me returned in results
OccCntA = 2
OccCntB = 2
OccCntC = 2
'Set min and max salary ranges to return for each occupation
OccASalmin = 1000000
OccASalmax = 6000000
OccBSalmin = 1000000
OccBSalmax = 6000000
OccCSalmin = 1000000
OccCSalmax = 6000000
'Get total number of entries
entryCount = rRng.Count
'Randomly get first required occupation entries
'Return list of rows for each Occupation
OccAList = PickRandomItemsFromList(OccCntA, entryCount, OccA, OccASalmin, OccASalmax)
OccBList = PickRandomItemsFromList(OccCntB, entryCount, OccB, OccBSalmin, OccBSalmax)
OccCList = PickRandomItemsFromList(OccCntC, entryCount, OccC, OccCSalmin, OccCSalmax)
For Each i In OccAList
If rangelist = "" Then
rangelist = "A" & i
Else
rangelist = rangelist & "," & "A" & i
End If
Next i
For Each i In OccBList
If rangelist = "" Then
rangelist = "A" & i
Else
rangelist = rangelist & "," & "A" & i
End If
Next i
For Each i In OccCList
If rangelist = "" Then
rangelist = "A" & i
Else
rangelist = rangelist & "," & "A" & i
End If
Next i
'Print the rows that match criteria
Dim rCntr As Long
rCntr = 1
Dim nRng As Range
Set nRng = Range(rangelist)
For Each j In nRng
Range(j, j.Offset(0, 2)).Select
Selection.Copy
Range("E" & rCntr).Select
ActiveSheet.Paste
rCntr = rCntr + 1
Next j
'Get rest of rows randomly and print
OccList = PickRandomItemsFromListB(totalnum - rCntr + 1, entryCount, rangelist)
For Each k In OccList
Set Rng = Range("A" & k)
Range(Rng, Rng.Offset(0, 2)).Select
Selection.Copy
Range("E" & rCntr).Select
ActiveSheet.Paste
rCntr = rCntr + 1
Next k
End Sub
Function PickRandomItemsFromListB(nItemsToPick As Long, nItemsTotal As Long, avoidRng As String)
Dim rngList As Range
Dim idx() As Long
Dim varRandomItems() As Variant
Dim i As Long
Dim j As Long
Dim booIndexIsUnique As Boolean
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
Do
booIndexIsUnique = True ' Innoncent until proven guilty
idx(i) = Int(nItemsTotal * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then
' It's already there.
booIndexIsUnique = False
Exit For
End If
Next j
Set isect = Application.Intersect(Range("A" & idx(i)), Range(avoidRng))
If booIndexIsUnique = True And isect Is Nothing Then
Exit Do
End If
Loop
varRandomItems(i) = idx(i)
Next i
PickRandomItemsFromListB = varRandomItems
' varRandomItems now contains nItemsToPick unique random
' items from range rngList.
End Function
Function PickRandomItemsFromList(nItemsToPick As Long, nItemsTotal As Long, Occ As String, Salmin As Long, Salmax As Long)
Dim rngList As Range
Dim idx() As Long
Dim varRandomItems() As Variant
Dim i As Long
Dim j As Long
Dim booIndexIsUnique As Boolean
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
Do
booIndexIsUnique = True ' Innoncent until proven guilty
idx(i) = Int(nItemsTotal * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then
' It's already there.
booIndexIsUnique = False
Exit For
End If
Next j
If booIndexIsUnique = True And Range("B" & idx(i)).Value = Occ And Range("B" & idx(i)).Offset(0, 1).Value >= Salmin And Range("B" & idx(i)).Offset(0, 1).Value <= Salmax Then
Exit Do
End If
Loop
varRandomItems(i) = idx(i)
Next i
PickRandomItemsFromList = varRandomItems
End Function
Results are printed in column E with the first results meeting the criteria. After those, the rest are random but don't repeat the previous ones:
I'm not doing very much error checking such as what happens if there are not 2 doctors or not enough entries left to meet the required number of results. You'll have to fine tune it for your purposes. You'll probably also want to set up the inputs as a form so you don't have to mess with code every time you change your criteria.