Welcome Guest
Log In | Register )
You last visited December 6, 2016, 3:06 am
All times shown are
Eastern Time (GMT-5:00)

Wheels using excel ?? Why Not!

Topic closed. 2 replies. Last post 11 years ago by wpb.

Page 1 of 1
PrintE-mailLink
lottaloot's avatar - AvatarZ56
Redford/MI
United States
Member #3396
January 18, 2004
4867 Posts
Offline
Posted: January 3, 2006, 8:54 pm - IP Logged

Found a great VBA that allows you to create wheels or permutations as they are called. 

Here's what you do. 

Place C in A1

""      3 in A2

And the numbers that you want in A3: down to whatever

Run the code in order to see that wheels...There will be another sheet added to your workbook.

Wink

L ttaL   T

    lottaloot's avatar - AvatarZ56
    Redford/MI
    United States
    Member #3396
    January 18, 2004
    4867 Posts
    Offline
    Posted: January 3, 2006, 9:02 pm - IP Logged

    Care of  http://www.ozgrid.com/forum/showthread.php?t=42056&highlight=permutations


    Option Explicit
     
     'Written by Myrna Larson - Microsoft Excel MVP
    Dim vAllItems As Variant
    Dim Buffer() As String
    Dim BufferPtr As Long
    Dim Results As Worksheet
     
     
    Sub ListPermutations()
        Dim Rng As Range
        Dim PopSize As Integer
        Dim SetSize As Integer
        Dim Which As String
        Dim N As Double
        Const BufferSize As Long = 4096
       
       
        Set Rng = Range(Range("A1"), Cells(Rows.Count, "A").End(xlUp))
       
        PopSize = Rng.Cells.Count - 2
        If PopSize < 2 Then GoTo DataError
       
        SetSize = Rng.Cells(2).Value
        If SetSize > PopSize Then GoTo DataError
       
        Which = UCase$(Rng.Cells(1).Value)
        Select Case Which
        Case "C"
            N = Application.WorksheetFunction.Combin(PopSize, SetSize)
        Case "P"
            N = Application.WorksheetFunction.Permut(PopSize, SetSize)
        Case Else
            GoTo DataError
        End Select
        If N > Cells.Count Then GoTo DataError
       
        Application.ScreenUpdating = False
       
        Set Results = Worksheets.Add
       
        vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
        ReDim Buffer(1 To BufferSize) As String
        BufferPtr = 0
       
        If Which = "C" Then
            AddCombination PopSize, SetSize
        Else
            AddPermutation PopSize, SetSize
        End If
        vAllItems = 0
       
        Application.ScreenUpdating = True
        Exit Sub
       
    DataError:
        If N = 0 Then
            Which = "Enter your data in a vertical range of at least 4 cells. " _
            & String$(2, 10) _
            & "Top cell must contain the letter C or P, 2nd cell is the number " _
            & "of items in a subset, the cells below are the values from which " _
            & "the subset is to be chosen."
           
        Else
            Which = "This requires " & Format$(N, "#,##0") & _
            " cells, more than are available on the worksheet!"
        End If
        MsgBox Which, vbOKOnly, "DATA ERROR"
        Exit Sub
    End Sub
     
    Private Sub AddPermutation(Optional PopSize As Integer = 0, _
        Optional SetSize As Integer = 0, _
        Optional NextMember As Integer = 0)
       
        Static iPopSize As Integer
        Static iSetSize As Integer
        Static SetMembers() As Integer
        Static Used() As Integer
        Dim i As Integer
       
        If PopSize <> 0 Then
            iPopSize = PopSize
            iSetSize = SetSize
            ReDim SetMembers(1 To iSetSize) As Integer
            ReDim Used(1 To iPopSize) As Integer
            NextMember = 1
        End If
       
        For i = 1 To iPopSize
            If Used(i) = 0 Then
                SetMembers(NextMember) = i
                If NextMember <> iSetSize Then
                    Used(i) = True
                    AddPermutation , , NextMember + 1
                    Used(i) = False
                Else
                    SavePermutation SetMembers()
                End If
            End If
        Next i
       
        If NextMember = 1 Then
            SavePermutation SetMembers(), True
            Erase SetMembers
            Erase Used
        End If
       
    End Sub 'AddPermutation
     
    Private Sub AddCombination(Optional PopSize As Integer = 0, _
        Optional SetSize As Integer = 0, _
        Optional NextMember As Integer = 0, _
        Optional NextItem As Integer = 0)
       
        Static iPopSize As Integer
        Static iSetSize As Integer
        Static SetMembers() As Integer
        Dim i As Integer
       
        If PopSize <> 0 Then
            iPopSize = PopSize
            iSetSize = SetSize
            ReDim SetMembers(1 To iSetSize) As Integer
            NextMember = 1
            NextItem = 1
        End If
       
        For i = NextItem To iPopSize
            SetMembers(NextMember) = i
            If NextMember <> iSetSize Then
                AddCombination , , NextMember + 1, i + 1
            Else
                SavePermutation SetMembers()
            End If
        Next i
       
        If NextMember = 1 Then
            SavePermutation SetMembers(), True
            Erase SetMembers
        End If
       
    End Sub 'AddCombination
     
    Private Sub SavePermutation(ItemsChosen() As Integer, _
        Optional FlushBuffer As Boolean = False)
       
        Dim i As Integer, sValue As String
        Static RowNum As Long, ColNum As Long
       
        If RowNum = 0 Then RowNum = 1
        If ColNum = 0 Then ColNum = 1
       
        If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
            If BufferPtr > 0 Then
                If (RowNum + BufferPtr - 1) > Rows.Count Then
                    RowNum = 1
                    ColNum = ColNum + 1
                    If ColNum > 256 Then Exit Sub
                End If
               
                Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
                = Application.WorksheetFunction.Transpose(Buffer())
                RowNum = RowNum + BufferPtr
            End If
           
            BufferPtr = 0
            If FlushBuffer = True Then
                Erase Buffer
                RowNum = 0
                ColNum = 0
                Exit Sub
            Else
                ReDim Buffer(1 To UBound(Buffer))
            End If
           
        End If
       
        'construct the next set
        For i = 1 To UBound(ItemsChosen)
            sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
        Next i
       
        'and save it in the buffer
        BufferPtr = BufferPtr + 1
        Buffer(BufferPtr) = Mid$(sValue, 3)
    End Sub 'SavePermutation

     

    L ttaL   T

      wpb's avatar - DiscoBallGlowing
      Charlotte North Carolina
      United States
      Member #464
      July 9, 2002
      17392 Posts
      Offline
      Posted: January 3, 2006, 9:07 pm - IP Logged

      Thank you for posting this site lottoloot, I was just trying to figure out how to get excel to give me all combo's to a four digit number.

       

      wpb