Results 1 to 5 of 5

Myrna Larson code for Combinations and Permutations not working in Excel 07-Overflow

Threaded View

PokerJoe Myrna Larson code for... 03-23-2009, 12:54 PM
shg Re: Myrna Larson code for... 03-23-2009, 01:21 PM
shg Re: Myrna Larson code for... 03-23-2009, 02:01 PM
PokerJoe Re: Myrna Larson code for... 03-23-2009, 05:58 PM
PokerJoe Re: Myrna Larson code for... 03-23-2009, 02:00 PM
  1. #1
    Registered User
    Join Date
    03-23-2009
    Location
    Bahama, NC
    MS-Off Ver
    Excel 2007
    Posts
    3

    Myrna Larson code for Combinations and Permutations not working in Excel 07-Overflow

    I've used the following code in Excel XP with no problems.
    Now that I have Excel 2007, I keep getting an "Overflow" error when trying to run the code. Sometimes it will say "Runtime error '6':, Overflow"

    When I step through the code (F8) the line that brings up the error is:

    If N > Cells.Count Then GoTo DataError

    To give an example of what values I'm entering use the following:

    Cell A1 = c
    Cell A2 = 5
    Cells A3 - A17 = A-O (one letter per cell)

    Any help would be greatly appreciated.

    Option Explicit
    Dim vAllItems As Variant
    Dim Buffer() As String
    Dim BufferPtr As Long
    Dim Results As Worksheet
    '
    '  Posted by Myrna Larson
    '  July 25, 2000
    '  Microsoft.Public.Excel.Misc
    '  Subject:  Combin
    '
    '
    'Since you asked, here it is. It is generic, i.e. it isn't written specifically
    'for a given population and set size, as yours it. It will do permutations or
    'combinations. It uses a recursive routine to generate the subsets, one routine
    'for combinations, a different one for permutations.
    'To use it, you put the letter C or P (for combinations or permutations) in a
    'cell. The cell below that contains the number of items in a subset. The Cells
    'below are a list of the items that make up the population. They could be
    'numbers, letters and symbols, or words, etc.
    'You select the top cell, or the entire range and run the sub. The subsets are
    'written to a new sheet in the workbook.
    '
    '
    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 = Selection.Columns(1).Cells
      If Rng.Cells.Count = 1 Then
        Set Rng = Range(Rng, Rng.End(xlDown))
      End If
      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
    Last edited by PokerJoe; 03-23-2009 at 01:59 PM.

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