View Full Version : List out all possible combination in the sheet
scrusader
06-23-2011, 11:57 PM
Hi,
How to list out all the possible combination of data in a worksheet?
For example, the user insert like this
A........ B....... C
D.................. E
.....................F
after user click a button
if become
A B C
A B E
A B F
D B C
D B E
D B F
Kenneth Hobs
06-24-2011, 05:29 AM
Welcome to the forum!
Obviously, there are 10 combinations. The attachment is fairly straightforward. Select A1 and click the button. I have already added the inputs for you. It will add a new sheet with output in the format of:
A, B, C
A, B, D
etc.
Paul_Hossler
06-25-2011, 10:36 AM
Actually I think there's only 6 if the first char in the triplet has to be A or D, the second char has to be B, and the third has to be C or E or F
2 x 1 x 3
This might not be the best way, but it's one way
Option Explicit
Sub Combines()
Dim rData As Range
Dim N As Long
Dim iCol As Long, iRow As Long, i As Long
Dim A() As String
Dim M() As Long
'save the working range
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
'save number in each column
ReDim M(1 To rData.Columns.Count)
For iCol = 1 To rData.Columns.Count
If rData.Cells(1, iCol).End(xlDown).Row = rData.Parent.Rows.Count Then
M(iCol) = 1
Else
M(iCol) = rData.Cells(1, iCol).End(xlDown).Row
End If
Next iCol
'find total number of combanations
N = 1
For iCol = 1 To rData.Columns.Count
N = N * M(iCol)
Next iCol
'create working array
ReDim A(1 To N, 1 To rData.Columns.Count)
'fill working array
For iCol = 1 To UBound(A, 2)
For iRow = 1 To UBound(A, 1)
A(iRow, iCol) = rData.Cells((iRow + 1) Mod M(iCol) + 1, iCol).Value
Next iRow
Next iCol
'display it on the column 2 over
For iRow = 1 To UBound(A, 1)
For iCol = 1 To UBound(A, 2)
rData.Cells(iRow, UBound(A, 2) + 2).Value = rData.Cells(iRow, UBound(A, 2) + 2).Value & A(iRow, iCol)
Next iCol
Next iRow
'sort to make pretty
rData.Cells(1, UBound(A, 2) + 2).CurrentRegion.Select
With rData.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=rData.Cells(1, UBound(A, 2) + 2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData.Cells(1, UBound(A, 2) + 2).CurrentRegion
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Paul
scrusader
06-26-2011, 07:32 PM
Thanks for the reply guys.
Sorry for the trouble but Paul when i have more than 1 row for the column containing the letter "b", it will still only process that column for 1 time . Is there method to solve it?
if it is like this
A........ B....... C
D.........E....... F
.....................G
it will become it will display ABC , ABC , ABF , ABF, ABG, ABG instead of ABC , AEC , ABF , AEF, ABG, AEG
Paul_Hossler
06-27-2011, 10:49 AM
I should have used more complicated data
Try this one. Not a elegant since I couldn't use Mod like I wanted to :whistle:
Option Explicit
Sub Combines()
Dim rData As Range
Dim N As Long, N1 As Long
Dim iCol As Long, iRow As Long
Dim A() As String
Dim M() As Long, iM() As Long
'save the working range
Set rData = Worksheets("sheet1").Cells(1, 1).CurrentRegion
'save number in each column
ReDim M(1 To rData.Columns.Count)
ReDim iM(1 To rData.Columns.Count)
For iCol = 1 To rData.Columns.Count
If rData.Cells(1, iCol).End(xlDown).Row = rData.Parent.Rows.Count Then
M(iCol) = 1
Else
M(iCol) = rData.Cells(1, iCol).End(xlDown).Row
End If
Next iCol
'find total number of combinations, and init counter array
N = 1
For iCol = 1 To rData.Columns.Count
N = N * M(iCol)
iM(iCol) = 1
Next iCol
'create working array
ReDim A(1 To N, 1 To rData.Columns.Count)
'fill working array
N1 = N
For iCol = 1 To UBound(A, 2)
N1 = N1 / M(iCol)
i = 0
For iRow = 1 To UBound(A, 1)
A(iRow, iCol) = rData.Cells(iM(iCol), iCol).Value
i = i + 1
If i = N1 Then
iM(iCol) = iM(iCol) + 1
If iM(iCol) > M(iCol) Then iM(iCol) = 1
i = 0
End If
Next iRow
Next iCol
'display it on the column 2 over
For iRow = 1 To UBound(A, 1)
For iCol = 1 To UBound(A, 2)
rData.Cells(iRow, UBound(A, 2) + 2).Value = rData.Cells(iRow, UBound(A, 2) + 2).Value & A(iRow, iCol)
Next iCol
Next iRow
End Sub
Paul
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.