Home |
Search |
Today's Posts |
#2
![]() |
|||
|
|||
![]()
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 |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
Stopping Charts Displaying Zero Results | Charts and Charting in Excel | |||
Show two value ranges on one axis | Charts and Charting in Excel | |||
Problem with graph ranges | Charts and Charting in Excel | |||
compare unique identifiers in multiple ranges | Charts and Charting in Excel | |||
Named dynamic ranges, copied worksheets and graph source data | Charts and Charting in Excel |