+ Reply to Thread
Results 1 to 5 of 5

Help with Amending this Code Please

  1. #1

    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


  2. #2
    Bernie Deitrick
    Guest

    Re: Help with Amending this Code Please

    Paul,

    Add this just below the declarations:

    Dim myWrap As Long
    myWrap = 10000 ' Select how long you want your columns to be here, with a
    max of 65536

    And then change the line with the Offset from:

    DestRange.Offset(Counter1 - 1) = ......

    to

    DestRange.Offset((Counter1 Mod myWrap), Int(Counter1 / myWrap)) = ......

    HTH,
    Bernie
    MS Excel MVP


    <[email protected]> wrote in message
    news:[email protected]...
    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 = 65001 Then
    Combinations = 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 = Range("A1:A20").Value
    SubSet = 5
    SepChar = "-"

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

    ReDim CountOff(SubSet)
    ReDim MaxOff(SubSet)

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

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

    Application.ScreenUpdating = False

    For Counter1 = 1 To NumOfComb
    NewComb = ""
    For Counter2 = 1 To SubSet
    NewComb = NewComb & CombString(CountOff(Counter2Â*), 1) & _

    SepChar
    Next Counter2
    DestRange.Offset(Counter1 - 1) = Left(NewComb, Len(NÂ*ewComb) -
    _
    Len(SepChar))
    CountOff(SubSet) = CountOff(SubSet) + 1
    Dummy = SubSet
    While Dummy > 1
    If CountOff(Dummy) > MaxOff(Dummy) Then
    CountOff(Dummy - 1) = CountOff(Dummy - 1) + Â*1
    For Counter2 = Dummy To SubSet
    CountOff(Counter2) = CountOff(Counter2 -Â* 1) + 1
    Next Counter2
    End If
    Dummy = Dummy - 1
    Wend
    Next Counter1

    Application.ScreenUpdating = True
    End Sub

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



  3. #3

    Re: Help with Amending this Code Please

    Thanks Bernie,

    It Works Except for One Thing, the Combinations Start in Cell "A2" in
    the First Column, But in Subsequent Columns they Start in the First Row
    which is OK.

    Thanks Again.
    All the Best
    Paul


  4. #4
    Bernie Deitrick
    Guest

    Re: Help with Amending this Code Please

    Paul,

    Use:

    DestRange.Offset(((Counter1 - 1) Mod myWrap), Int((Counter1 - 1) / myWrap))
    =

    HTH,
    Bernie
    MS Excel MVP

    <[email protected]> wrote in message
    news:[email protected]...
    > Thanks Bernie,
    >
    > It Works Except for One Thing, the Combinations Start in Cell "A2" in
    > the First Column, But in Subsequent Columns they Start in the First Row
    > which is OK.
    >
    > Thanks Again.
    > All the Best
    > Paul
    >




  5. #5

    Re: Help with Amending this Code Please

    Hi Bernie,

    Brilliant, It Works Perfect.
    Thanks for All your Help.

    All the Best
    Paul


+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1