I think this is what you are looking for. I often use it for bank
reconciliations. It has a limit of 15 variables.
HTH,
Gary Brown
'/================================/
Sub Combos()
'Gary L. Brown
'03/18/2001
'04/04/2001 - sorting and formatting
'05/01/2002 - add'l formatting
'
'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, strRngInputAddress As String
Dim strWorksheetName As String
Dim strResultsTableName As String
Dim varAnswer As Variant
Dim strOrigCalcStatus As String
'save calculation setting
Select Case Application.Calculation
Case xlCalculationAutomatic
strOrigCalcStatus = "Automatic"
Case xlCalculationManual
strOrigCalcStatus = "Manual"
Case xlCalculationSemiautomatic
strOrigCalcStatus = "SemiAutomatic"
Case Else
strOrigCalcStatus = "Automatic"
End Select
'set workbook to manual
Application.Calculation = xlManual
'/----------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.... www.kinneson.com", _
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(strWorksheetName)
'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(COUNTA(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:
Select Case strOrigCalcStatus
Case "Automatic"
Application.Calculation = xlCalculationAutomatic
Case "Manual"
Application.Calculation = xlCalculationManual
Case "SemiAutomatic"
Application.Calculation = xlCalculationSemiautomatic
Case Else
Application.Calculation = xlCalculationAutomatic
End Select
Set rngInput = Nothing
End Sub
'/================================/
"iart" wrote in message
...
hi
i am analyzing numbers. i have 6 distinct columns of numbers. each column
has 5 to 7 variables. What I want to do is program each column with its
variables, and have excel spit out all the possible unique combinations of
those numbers
for example:
col1 col2 col3 col4 col5 col6
1 10 21 34 40 11
3 14 23 37 42 14
4 17 28 38 43 18
5 19 30 39 44 20
What I want the spread sheet to do is spit out all the possible *unique*
combinations of those numbers, with only the numbers showing in any of the
columns at anytime that are uniquely assigned to the columns.
if excel cannot do this, if you know of a program that does please let me
know
thanks
|