Need Help with revision of current VBA macro! please!

[estatefinds]

I will attach an example of what I have and instructions on the actual worksheet. Really need help with this one!!!
Sincerely Dennis

ALT F8 RUNS THE CURRENT MACRO

[estatefinds]

Need help with this VBA Macro, please!
here is a description of what I'm looking for. I need a new macro basedon the one I have now same basic idea, meaning producing combinations fromindividual columns.
The data I have set up is in the columns E94:AC98 this data will changebut before it changes I need to run the macro to produce the combinations.
the macro would start at E94 for example the number 1 happens to be there,to start building a five number combination. a number from each column is used,meaning a number used from a different column MEANING two numbers in a column can’t be used together it has to be one number from each column, so the combinations will be made up of five numbers and five columns. Starting from left to right, the numbers run from 1 to 35.
so the first number out of the column E94 is 1 then it goes to the next column F as the next number is 8 then it would go to the next column G forthe next number 12 then it would meaning the (macro) would go to the next column H for the next number is 14 then the macro goes to the next column I for the next number 18; a combination is built. So once all the combinations are made using the using the numbers in the EFGHI the macro will start using the numbers in the EFGHJ then use the numbers in EFGHK, and EFGHL and so on until completed then the macro will start at the FGHIJ and do the same and this will continue until it reaches the last set of columns in this case QRSTU.

[mikerickson]

That's an incredibly large number of combinations, but I think that this will do what you want.

Right now this is set up to work on the data in Sheet5, but you can adjust the ranges to suit what you want.


Sub test()
Const Delimiter As String = "-"
Dim BigRange As Range
Dim AllColumnsCount As Long
Dim ChoiceArray() As Boolean
Dim CountOfReturn As Long
Dim ColumnWorking() As Range
Dim ColumnIndex() As Long
Dim ResultRange As Range
Dim OverFlow As Boolean, flag As Boolean, halt As Boolean
Dim subHeader As String, oneResult As String

Dim i As Long, Pointer As Long

Set BigRange = Sheet2.Range("A1"): Rem adjust
Set ResultRange = Sheet2.Range("A10"): Rem adjust

Set BigRange = BigRange.CurrentRegion
AllColumnsCount = BigRange.Columns.Count
Set ResultRange = ResultRange.Cells(1, 1)

CountOfReturn = Application.InputBox("How Many?", Default:=5, Type:=1)
If CountOfReturn = 0 Then Exit Sub: Rem cancel pressed

Application.ScreenUpdating = False
ReDim ChoiceArray(1 To AllColumnsCount)
For i = 1 To CountOfReturn
ChoiceArray(i) = True
Next i

With ResultRange
Range(.EntireColumn.Cells(Rows.Count, 2), .Cells).ClearContents
End With
ResultRange.Value = "Combinations"
ReDim ColumnWorking(1 To CountOfReturn)
ReDim ColumnIndex(1 To CountOfReturn)

Do
Rem process one choice
Pointer = 0
subHeader = vbNullString
For i = 1 To AllColumnsCount
If ChoiceArray(i) Then
Pointer = Pointer + 1
Set ColumnWorking(Pointer) = BigRange.Cells(1, i)
ColumnIndex(Pointer) = 1
subHeader = subHeader & "," & Split(ColumnWorking(Pointer).Address(True, False), "$")(0)
End If
Next i
ResultRange.EntireColumn.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Value = Mid(subHeader, 2)

GoSub MakeResult

Rem next combin
halt = False
Do
flag = False
Pointer = CountOfReturn

Do
ColumnIndex(Pointer) = ColumnIndex(Pointer) + 1
If ColumnWorking(Pointer).Cells(ColumnIndex(Pointer), 1) = vbNullString Then
ColumnIndex(Pointer) = 1
Pointer = Pointer - 1
If Pointer < 1 Then halt = True
Else
flag = True
End If
Loop Until flag Or halt
GoSub MakeResult
Loop Until halt

NextChoice ChoiceArray, OverFlow
Loop Until OverFlow

ResultRange.EntireColumn.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1).Value = "Done"
Application.ScreenUpdating = True
Exit Sub
MakeResult:
oneResult = vbNullString
For i = 1 To CountOfReturn
oneResult = oneResult & Delimiter & ColumnWorking(i).Cells(ColumnIndex(i)).Value
Next i
oneResult = Mid(oneResult, Len(Delimiter) + 1)
ResultRange.EntireColumn.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = oneResult
Return
End Sub

Sub NextChoice(ByRef ChoiceArray As Variant, Optional ByRef OverFlow As Boolean)
Dim Pointer As Long, writeTo As Long
Pointer = LBound(ChoiceArray) - 1
writeTo = Pointer
Do
Pointer = Pointer + 1
Loop Until ChoiceArray(Pointer)

Do
writeTo = writeTo + 1

ChoiceArray(Pointer) = False
ChoiceArray(writeTo) = True
Pointer = Pointer + 1
OverFlow = (UBound(ChoiceArray) < Pointer)
If OverFlow Then Exit Do
Loop Until Not (ChoiceArray(Pointer))
If OverFlow Then
Exit Sub
Else
ChoiceArray(writeTo) = False
ChoiceArray(Pointer) = True
End If
End Sub

[estatefinds]

I ran it and it works GREAT!!! Thank you very much!!!!
Sincerely Dennis