1) List out the 12 combinations for
1a,1b,1c,2a,2b,2c,3a,3b,3c,4a,4b,4c
This will derive 4,096 combinations (2^12)
The macro listed below will create a worksheet with all 4,096 combinations.
I use it for check reconciliations at works. I currently have it set up for
15 selections or less because 2^15 = 32,768 and I didn't want to deal with
wrapping into more columns.
HTH,
Gary Brown
gary_brown@ge_NOSPAM.com
If this post was helpful, please click the ''''Yes'''' button next to
''''Was this Post Helpfull to you?".
'/=================================================/
Sub Combos()
'This program will give the addition of each combination
' of cells selected
'The # of combinations is calculated as
' [2^(# of cells selected)] - 1
'
On Error Resume Next
Dim aryHiddensheets()
Dim aryNum() As Double, aryExp() As String
Dim aryA()
Dim dblLastRow As Double, dblRow As Double
Dim i As Double
Dim x As Integer, iMaxCount As Integer
Dim z As Integer, r As Integer
Dim y As Integer, iWorksheets As Integer
Dim iCol As Integer
Dim iCount As Integer
Dim objCell As Object
Dim rngInput As Range
Dim strOriginalAddress As String
Dim strRngInputAddress As String
Dim strWorksheetName As String
Dim strResultsTableName As String
Dim varAnswer As Variant
'/----------start-up Variables-------------/
strResultsTableName = "Combinations_Listing"
strOriginalAddress = Selection.Address
strWorksheetName = ActiveSheet.Name
iMaxCount = 15
'/----------end start-up Variables---------/
Set rngInput = _
Application.InputBox(Prompt:= _
"Select Range of Numbers to be used as input for " & _
"combinations output" & vbCr & vbCr & _
"Note: Currently limited to " & _
iMaxCount & " cells or less", _
Title:="Combinations....", _
Default:=strOriginalAddress, Type:=8)
'get how many cells have been selected and location
iCount = rngInput.Count
strRngInputAddress = rngInput.Address
Select Case iCount
Case 0
MsgBox "No cells have been selected." & vbCr & _
vbCr & "Process aborted...", _
vbExclamation + vbOKOnly, _
"Warning..."
GoTo exit_Sub
Case 1 To iMaxCount
i = (2 ^ iCount) - 1
varAnswer = MsgBox("The " & iCount & _
" selected cell(s) will produce " & _
Application.WorksheetFunction.Text(i, "#,##") & _
" combinations." & vbCr & "Do you wish to continue?", _
vbInformation + vbYesNo, _
"Combinations...")
If varAnswer = vbNo Then Exit Sub
Case Is > iMaxCount
varAnswer = _
MsgBox("Only the first " & iMaxCount & _
" cells in the range <<< " & _
strRngInputAddress & " >>> will be processed." & vbCr & _
vbCr & "Continue?", vbExclamation + vbYesNo, "Warning")
If varAnswer = vbNo Then Exit Sub
End Select
If iCount > iMaxCount Then iCount = iMaxCount
'now that we can calculate the actual dimensions
' we can re-dimension the arrays
ReDim aryNum(1 To iCount)
ReDim aryA(1 To ((2 ^ iCount) - 1), 1 To 2)
ReDim aryExp(1 To iCount)
'populate the array with the values in the selected cells
i = 0
For Each objCell In rngInput
i = i + 1
If i > iMaxCount Then Exit For
aryNum(i) = objCell.Value
aryExp(i) = _
Application.WorksheetFunction.Text(objCell.Value, "@")
Next objCell
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'redim array
ReDim aryHiddensheets(1 To iWorksheets)
'put hidden sheets in an array, then unhide the sheets
For x = 1 To iWorksheets
If Worksheets(x).Visible = False Then
aryHiddensheets(x) = Worksheets(x).Name
Worksheets(x).Visible = True
End If
Next
'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If UCase(Worksheets(x).Name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Exit For
End If
Next
'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move After:=Worksheets(ActiveSheet.Name)
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.Name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").Value = "Amount"
ActiveWorkbook.ActiveSheet.Range("B1").Value = "Combo"
Range("A1:B1").Font.Bold = True
On Error Resume Next
Range("A2").Select
'initialize variable to desired values
z = 1
y = 1
dblRow = 2
iCol = 1
'add the first element
aryA(y, 1) = aryNum(z)
aryA(y, 2) = "'" & Format(aryExp(z), "#,##0.00")
'initialize arrays with combos
For z = 2 To iCount
y = y + 1
aryA(y, 1) = aryNum(z)
aryA(y, 2) = "'" & Format(aryExp(z), "#,##0.00")
For x = 1 To ((2 ^ (z - 1)) - 1)
y = y + 1
aryA(y, 1) = aryA(x, 1) + aryNum(z)
aryA(y, 2) = aryA(x, 2) & " + " & _
Format(aryExp(z), "#,##0.00")
Next x
Next z
'put array info into worksheet
For r = 1 To y
Cells(dblRow, iCol) = aryA(r, 1)
Cells(dblRow, iCol + 1) = aryA(r, 2)
dblRow = dblRow + 1
If dblRow >= 65000 Then
dblRow = 2
iCol = iCol + 4
End If
Next r
'format worksheet
Cells.Select
Range(Selection, _
ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("A2"), _
Order1:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
ActiveWindow.Zoom = 75
Range("A1:B1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Selection.Font.Underline = xlUnderlineStyleSingle
Columns("A:A").Select
Selection.NumberFormat = _
"_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
Columns("A:B").Select
Columns("A:B").EntireColumn.AutoFit
Columns("B:B").Select
If Selection.ColumnWidth > 75 Then
Selection.ColumnWidth = 75
End If
Selection.HorizontalAlignment = xlLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
dblLastRow = dblLastRow + 1
'adjust info for max # of processed cells
If iCount > 15 Then iCount = 15
Application.ActiveCell.Formula = "=Text(SUBTOTAL(3,A3:A" & _
dblLastRow + 10 & ")," & Chr(34) & _
"#,##0" & Chr(34) & ") & " & _
Chr(34) & " Combinations found for " & _
Application.WorksheetFunction.Text(iCount, "#,##") & _
" selections in range: " & _
strRngInputAddress & Chr(34)
Selection.Font.Bold = True
're-hide previously hidden sheets
y = UBound(aryHiddensheets)
For x = 1 To y
Worksheets(aryHiddensheets(x)).Visible = False
Next
Cells.Select
With Selection.Font
.Name = "Tahoma"
.Size = 10
End With
Range("A3").Select
ActiveWindow.FreezePanes = True
Application.Dialogs(xlDialogWorkbookName).Show
exit_Sub:
Set rngInput = Nothing
Exit Sub
End Sub
'/=================================================/
LAdekoya said:
I have four data elements and each can have one of three possible data values
at any one point in time. How can I auto-generate in excel, the various
possible data value combinations/mixes that I can get for these four items?
Assume the data elements are 1, 2, 3 & 4 and that the possible values are a,
b & c. Any help would be greatly appreciated.
