View Single Post
  #1   Report Post  
 
Posts: n/a
Default Help with Amending this Code Please

Leo Heuser Posted this Code in 2002, which Works Very Well.
Ideally, I would like this Code to be Amended so that it can List MORE
Than 65,536 Combinations. Maybe List Combinations in the First Column
from A1:A65000 and then Goto Column"B" and Continue.
I know that it Needs Some Sort of Code Like :-

If Combinations =3D 65001 Then
Combinations =3D 1
ActiveCell.Offset(-65000, 1).Select
End If

I have Tried Numerous Ways But to NO Avail.
Any Help would be Appreciated.

Here is Leo Heusers Code :-
************************************************** ***************
Sub CombinationsFromRange()
Dim DestRange As Object
Dim CountOff()
Dim MaxOff()
Dim CombString As Variant
Dim SepChar As String
Dim NewComb As String
Dim NumOfComb As Long
Dim Dummy
Dim SubSet As Long
Dim NumOfElements As Long
Dim Counter1 As Long
Dim Counter2 As Long

CombString =3D Range("A1:A20").Value
SubSet =3D 5
SepChar =3D "-"

NumOfElements =3D UBound(CombString)
NumOfComb =3D Application.Combin(NumOfElements, SubSet)

ReDim CountOff(SubSet)
ReDim MaxOff(SubSet)

For Counter1 =3D 1 To SubSet
CountOff(Counter1) =3D Counter1
MaxOff(Counter1) =3D NumOfElements - SubSet + Counter1
Next Counter1

Worksheets.Add
Set DestRange =3D Range("a1")

Application.ScreenUpdating =3D False

For Counter1 =3D 1 To NumOfComb
NewComb =3D ""
For Counter2 =3D 1 To SubSet
NewComb =3D NewComb & CombString(CountOff(Counter2=AD), 1) & _

SepChar
Next Counter2
DestRange.Offset(Counter1 - 1) =3D Left(NewComb, Len(N=ADewComb) -
_
Len(SepChar))
CountOff(SubSet) =3D CountOff(SubSet) + 1
Dummy =3D SubSet
While Dummy 1
If CountOff(Dummy) MaxOff(Dummy) Then
CountOff(Dummy - 1) =3D CountOff(Dummy - 1) + =AD1
For Counter2 =3D Dummy To SubSet
CountOff(Counter2) =3D CountOff(Counter2 -=AD 1) + 1
Next Counter2
End If
Dummy =3D Dummy - 1
Wend
Next Counter1

Application.ScreenUpdating =3D True
End Sub

--
Best regards
Leo Heuser
MVP Excel
************************************************** ***************
Thanks in Advance.
All the Best
Paul