Fatal编程技术网
  • excel/
  • Excel 排列以尽可能找到最好的团队

Excel 排列以尽可能找到最好的团队

excel vba

Excel 排列以尽可能找到最好的团队,excel,permutation,vba,Excel,Permutation,Vba,我试着用另一种方式问这个问题，以得到一些回应。我一直在寻找排列，以找到一个团队的最佳价值，但我似乎找不到任何材料，让我清楚地了解我需要做什么。。初学者在excel中创建排列表 我希望实现的目标。我想获得可能的梦幻足球队的前100名（如果可能的话，甚至更多） 我不太确定如何设置，因为我需要每个排列包括每个位置，如下QB、RB、RB、WR、WR、TE（6个起动器）。由于每个位置都有不同数量的球员可供选择，我不确定如何将所有这些放在一起，或者最好的方法是什么，所以我请求帮助 我希望结果是什么 Posi

我试着用另一种方式问这个问题，以得到一些回应。我一直在寻找排列，以找到一个团队的最佳价值，但我似乎找不到任何材料，让我清楚地了解我需要做什么。。初学者在excel中创建排列表

我希望实现的目标。我想获得可能的梦幻足球队的前100名（如果可能的话，甚至更多）

我不太确定如何设置，因为我需要每个排列包括每个位置，如下QB、RB、RB、WR、WR、TE（6个起动器）。由于每个位置都有不同数量的球员可供选择，我不确定如何将所有这些放在一起，或者最好的方法是什么，所以我请求帮助

我希望结果是什么

Position QB   RB   RB   WR   WR    TE   Total
Fantasy 350  110 115  220  120   125   1040
并在整个排列过程中继续使用上述格式，找出最好的团队

玩家将来自不同的专栏，如下所示：

qb               rb
peyton 350   jamaal 235
drew   345
我不确定这是否可行，但我找到了一个宏，它只会给我可能的位置结果（QB、RB、WR等），但我似乎不知道如何将点组合到位置，并显示每个球员在各自位置的所有排列

再次感谢。

这不是正确的算法站点。它专门帮助编程。不过，我会尽力让你开始。请将以下每个步骤视为一项单独的任务。创建将执行任务1的宏。如果可行，请将其更新以创建执行任务1和任务2的宏。我已经尝试定义了每个步骤，因此它是一个单独的问题，如果需要，您可以搜索答案。例如，对于第一步，在Stackoverflow中搜索“[excel vba]Find last column”将给出相关的问题和答案，这些问题和答案显示了此任务的最常用技术

我假设你有一份工作表，其中包含每个位置的球员。大概是这样的：

   A       B       C       D       E       F       G       H       ...
1  QB              RB              RB              WR              ...
2  Albert  100     Bernard 150     Charles 200     David   150
3  Eric    250     Fred    125     George  175     Ian     215
4      :               :                :              :               :                :              :                :
你说你现在有六名先发球员。这是否意味着一旦你了解问题，你会增加更多的球员？无论哪种方式，第一项任务都是确定职位的数量

对于六个位置，第1行中的最后一个值将位于第11列，最后一列中的值将为12。对于不同数量的位置，这些值将为N和N+1，其中N+1为偶数，位置数量为（N+1）/2

你说每个位置会有不同数量的球员。任务2是确定并记录每个位置的球员人数。搜索“[excel vba]查找最后一行”将提供多种技术

我将创建一个动态数组，类似于：

Dim RowPlayerMax() As Long
ReDim RowPlayerMax(1 to NumPositions)
然后，我将循环每个位置，并在
RowPlayerMax（PositionNum）
中记录列
PositionNum*2
的最后一行

您会注意到，我没有向您展示该循环的代码。这是一个程序员互相帮助开发的网站。我将向您展示如何将您的需求分解为几个小步骤。如果我也向您展示VBA，我就不会帮助您开发。您需要了解每个步骤的VBA，如果您发现VBA适合您自己，这将更好地促进您的发展

您需要将球员每个位置的数据加载到内存中，以便快速访问。我将把所有这些数据加载到一个
变量中，该变量将创建一个二维数组。第1行的第1、3、5等列将包含位置名称。第2行将包含第一组球员姓名和分数。数组
RowPlayerMax
将标识每个位置的最后一行

我认为下一步是决定生成置换的顺序。首先是最简单的顺序

您已经有了数组
RowPlayerMax
。您需要另一个大小相同的数组：
RowPlayerCrnt
。您已经初始化了
RowPlayerMax
。您可以将
RowPlayerCrnt
初始化为每个位置球员表中第一个数据行的编号，即2。为
RowPlayerMax
数组生成一些值，您有：


Element           1    2     3    4     5    6
RowPlayerMax     20    5    12    3    15    9
RowPlayerCrnt     2    2     2    2     2    2


然后进入
Do While True
循环


Do
循环中的第一个任务是记录由
RowPlayerCrnt
定义的排列。根据我的示例数据，这是艾伯特、伯纳德、查尔斯、大卫等，总数为100+150+200+100


Do
循环中的第二个任务是生成下一个排列。从1到
NumPositions
或相反方向运行的
循环需要
。我将从1转到
NumPositions

查看每个位置并对照最大值检查其当前值。如果某个位置的当前值小于最大值，则按一步执行，然后退出
for
循环。如果当前值等于最大值，则将其设置为第一个数据行，并继续执行
For
循环。如果退出
For
循环而不单步执行当前值，则生成了每个排列

想想这意味着什么。第一个排列是
2-2-2-2-2-2
。在第一个回路中，根据最大值（20）检查位置1（2）的当前值。因为2小于20，所以在2上加1。第二种排列是
3-2-2-2-2
。第三种排列是
4-2-2-2-2-2
，依此类推，直到
20-2-2-2-2


使用<代码> 202-2-2-2-2，位置1的当前值等于其最大值，因此它被设置为2，并且循环继续考虑位置2。位置2的当前值低于其最大值，因此添加了一个。这将给出下一个排列，即
2-3-2-2-2

这将一直持续到排列为
20-5-12-3-15-9
。不可能增加这些当前值中的任何一个，因此所有排列都是透明的

2-2-2-2-2-2
2-2-2-2-2-3
2-2-2-2-3-2
2-2-2-3-2-2
2-2-3-2-2-2
2-3-2-2-2-2
3-2-2-2-2-2
2-2-2-2-2-4
2-2-2-2-4-2
2-2-2-2-4-3
and so on.



Option Explicit
Sub Test1()

  ' * Task 1 is to discover the number of columns in worksheet
  '   PlayerPerPosition. I demonstrate two techniques.
  ' * Technique 1 which uses the VBA equivalent of Ctrl+Left is
  '   the most popular technique judging from how often it is used
  '   in answers on this site.  However, like all other techniques,
  '   it does not work in every situation.
  ' * The Find method is the most widely applicable technique although,
  '   as the second example shows, you must be careful how you search.

  Dim ColPppMax As Long

  With Worksheets("PlayerPerPosition")

    ' Use VBA equivalenent of Ctrl+Left to find last value in row 1
    ColPppMax = .Cells(1, Columns.Count).End(xlToLeft).Column
    ' Maximum used column is one more than last column with a value in header row
    ColPppMax = ColPppMax + 1
    Debug.Print ColPppMax

    ' Use Find to find last column
    ' Note I am searching by columns
    ColPppMax = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
    Debug.Print ColPppMax

    ' See what happens if I search by rows
    ColPppMax = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Column
    Debug.Print ColPppMax

  End With

End Sub
Sub Test2()

  ' * Task 2 is save the number of rows per position in worksheet
  '   PlayerPerPosition.  I use the VBA equivalement of Ctrl+Up.
  ' * Task 3 is to load the whole of worksheet PlayerPerPosition to
  '   an array.  For this I need to know the maximum used row for
  '   any position.

  Dim ColPppCrnt As Long
  Dim ColPppMax As Long
  Dim NumPosns As Long
  Dim PosnNumCrnt As Long
  Dim PppTable As Variant
  Dim RowPppMax() As Long
  Dim RowPppCrnt As Long
  Dim RowPppMaxMax As Long

  With Worksheets("PlayerPerPosition")

    ColPppMax = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column

    NumPosns = ColPppMax / 2       ' I ought to check there are an even number of columns

    ReDim RowPppMax(1 To NumPosns)

    RowPppMaxMax = 0
    PosnNumCrnt = 1
    For ColPppCrnt = 2 To ColPppMax Step 2
      RowPppMax(PosnNumCrnt) = .Cells(Rows.Count, ColPppCrnt).End(xlUp).Row
      If RowPppMaxMax < RowPppMax(PosnNumCrnt) Then
        ' If this position has more rows than any previous position, record new maximum row
        RowPppMaxMax = RowPppMax(PosnNumCrnt)
      End If
      PosnNumCrnt = PosnNumCrnt + 1
    Next

    'Output maximum row for each column
    Debug.Print "Position ";
    For PosnNumCrnt = 1 To NumPosns
      Debug.Print Right("   " & PosnNumCrnt, 3);
    Next
    Debug.Print
    Debug.Print " Max Row ";
    For PosnNumCrnt = 1 To NumPosns
      Debug.Print Right("   " & RowPppMax(PosnNumCrnt), 3);
    Next
    Debug.Print

    ' Load worksheet to variant as two-dimensional array
    PppTable = .Range(.Cells(1, 1), .Cells(RowPppMaxMax, ColPppMax)).Value

  End With

  ' Display Players Per Position table
  For RowPppCrnt = 1 To RowPppMaxMax
    For ColPppCrnt = 1 To ColPppMax Step 2
      ' Assume maximum of six characters per player name and
      ' maximum of 9999 for number of points
      Debug.Print Left(PppTable(RowPppCrnt, ColPppCrnt) & Space(6), 6) & " " & _
                  Right("   " & PppTable(RowPppCrnt, ColPppCrnt + 1), 3) & " ";
    Next
    Debug.Print
  Next

End Sub
Sub Test3()

  ' This macro generates the indices into the Ppp Table from which the
  ' actual permutations will be generated.

  ' If you have multi-row headers, using constants makes the code easy to change.
  Const RowPppDataFirst As Long = 2

  Dim ColPppCrnt As Long
  Dim ColPppMax As Long
  Dim GenerationFinished As Boolean
  Dim NumPosns As Long
  Dim PermStr As String
  Dim PosnNumCrnt As Long
  Dim PppTable As Variant
  Dim RowPermCrnt As Long
  Dim RowPppCrnt() As Long
  Dim RowPppMax() As Long
  Dim RowPppMaxMax As Long
  Dim TimeStart As Single

  TimeStart = Timer   ' Seconds since midnight

  ' Stops screen flash and speeds up macro when writing to worksheet
  Application.ScreenUpdating = False

  With Worksheets("PlayerPerPosition")

    ColPppMax = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column

    NumPosns = ColPppMax / 2       ' I ought to check there are an even number of columns

    ReDim RowPppMax(1 To NumPosns)

    RowPppMaxMax = 0
    PosnNumCrnt = 1
    For ColPppCrnt = 2 To ColPppMax Step 2
      RowPppMax(PosnNumCrnt) = .Cells(Rows.Count, ColPppCrnt).End(xlUp).Row
      If RowPppMaxMax < RowPppMax(PosnNumCrnt) Then
        ' If this position has more rows than any previous position, record new maximum row
        RowPppMaxMax = RowPppMax(PosnNumCrnt)
      End If
      PosnNumCrnt = PosnNumCrnt + 1
    Next

    PppTable = .Range(.Cells(1, 1), .Cells(RowPppMaxMax, ColPppMax)).Value

  End With

   ' Initialise current row table
  ReDim RowPppCrnt(1 To NumPosns)
  For PosnNumCrnt = 1 To NumPosns
    RowPppCrnt(PosnNumCrnt) = RowPppDataFirst
  Next

  RowPermCrnt = 1

  With Worksheets("Permutations")

    Do While True

      ' Output current permutation
      PermStr = RowPppCrnt(1)
      For PosnNumCrnt = 2 To NumPosns
        PermStr = PermStr & "-" & RowPppCrnt(PosnNumCrnt)
      Next
      .Cells(RowPermCrnt, 1).Value = PermStr
      RowPermCrnt = RowPermCrnt + 1

      ' Generate next permulation index
      GenerationFinished = True     ' Assume finishe until find otherwise
      For PosnNumCrnt = 1 To NumPosns
        If RowPppCrnt(PosnNumCrnt) < RowPppMax(PosnNumCrnt) Then
          RowPppCrnt(PosnNumCrnt) = RowPppCrnt(PosnNumCrnt) + 1
          GenerationFinished = False
          Exit For
        End If
        RowPppCrnt(PosnNumCrnt) = RowPppDataFirst
      Next
      If GenerationFinished Then
        Exit Do
      End If

   Loop

  End With

  Debug.Print "Duration " & Format(Timer - TimeStart, "##0.00")

End Sub
Sub Test4()

  ' This macro generates actual permutations.

  Const RowPppPosnName As Long = 1
  Const RowPppDataFirst As Long = 2

  Dim ColPppCrnt As Long
  Dim ColPppMax As Long
  Dim GenerationFinished As Boolean
  Dim NumPosns As Long
  Dim PointsTotal As Long
  Dim PosnNumCrnt As Long
  Dim PppTable As Variant
  Dim RowPermCrnt As Long
  Dim RowPppCrnt() As Long
  Dim RowPppMax() As Long
  Dim RowPppMaxMax As Long
  Dim TimeStart As Single

  TimeStart = Timer   ' Seconds since midnight

  Application.ScreenUpdating = False

  With Worksheets("PlayerPerPosition")

    ColPppMax = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column

    NumPosns = ColPppMax / 2       ' I ought to check there are an even number of columns

    ReDim RowPppMax(1 To NumPosns)

    RowPppMaxMax = 0
    PosnNumCrnt = 1
    For ColPppCrnt = 2 To ColPppMax Step 2
      RowPppMax(PosnNumCrnt) = .Cells(Rows.Count, ColPppCrnt).End(xlUp).Row
      If RowPppMaxMax < RowPppMax(PosnNumCrnt) Then
        ' If this position has more rows than any previous position, record new maximum row
        RowPppMaxMax = RowPppMax(PosnNumCrnt)
      End If
      PosnNumCrnt = PosnNumCrnt + 1
    Next

    PppTable = .Range(.Cells(1, 1), .Cells(RowPppMaxMax, ColPppMax)).Value

  End With

   ' Initialise current row table
  ReDim RowPppCrnt(1 To NumPosns)
  For PosnNumCrnt = 1 To NumPosns
    RowPppCrnt(PosnNumCrnt) = RowPppDataFirst
  Next

  With Worksheets("Permutations")

    .Cells.EntireRow.Delete     ' Delete any previous output

    ' Generate header row
    RowPermCrnt = 1
    PosnNumCrnt = 1   ' Uses as column number for Permutations worksheets
    For ColPppCrnt = 1 To ColPppMax Step 2
      .Cells(RowPermCrnt, PosnNumCrnt).Value = PppTable(RowPppPosnName, ColPppCrnt)
      PosnNumCrnt = PosnNumCrnt + 1
    Next
    With .Cells(RowPermCrnt, NumPosns + 1)
      .Value = "Total"
      .HorizontalAlignment = xlRight
    End With
    .Range(.Cells(1, 1), .Cells(1, NumPosns + 1)).Font.Bold = True

    RowPermCrnt = RowPermCrnt + 1

    Do While True

      ' Output current permutation
      PointsTotal = 0
      ColPppCrnt = 1
      For PosnNumCrnt = 1 To NumPosns
        .Cells(RowPermCrnt, PosnNumCrnt).Value = PppTable(RowPppCrnt(PosnNumCrnt), ColPppCrnt)
        ColPppCrnt = ColPppCrnt + 1
        PointsTotal = PointsTotal + PppTable(RowPppCrnt(PosnNumCrnt), ColPppCrnt)
        ColPppCrnt = ColPppCrnt + 1
      Next
      .Cells(RowPermCrnt, NumPosns + 1).Value = PointsTotal
      RowPermCrnt = RowPermCrnt + 1

      ' Generate next permulation index
      GenerationFinished = True     ' Assume finishe until find otherwise
      For PosnNumCrnt = 1 To NumPosns
        If RowPppCrnt(PosnNumCrnt) < RowPppMax(PosnNumCrnt) Then
          RowPppCrnt(PosnNumCrnt) = RowPppCrnt(PosnNumCrnt) + 1
          GenerationFinished = False
          Exit For
        End If
        RowPppCrnt(PosnNumCrnt) = RowPppDataFirst
      Next
      If GenerationFinished Then
        Exit Do
      End If

   Loop

  End With

  Debug.Print "Duration " & Format(Timer - TimeStart, "##0.00")

End Sub



Position    QB     RB     RB     WR     WR     TE
Column      1      2      3      4      5      6
PppTable

Position    QB     RB     RB     WR     WR     TE
Column      1      2      3      4      5      6
RowPppCrnt  a      b      c      d      e      f



Position    QB     RB     WR     TE
Column      1      2      3      4
PppTable

Position    QB     RB     RB     WR     WR     TE
Column      1      2      3      4      5      6
SwitchCol   1      2      2      3      3      4
RowPppCrnt  a      b      c      d      e      f



Sub Test5()

  ' This macro saves the 200 permulations with the highest permitted totals.

  Const RowPppPosnName As Long = 1
  Const RowPppDataFirst As Long = 2
  Const PointsTotalMaxPermitted As Long = 1000

  Dim ColPppCrnt As Long
  Dim ColPppMax As Long
  Dim GenerationFinished As Boolean
  Dim NumPermsGenerated As Long
  Dim NumPosns As Long
  Dim PermCrnt() As Variant
  Dim PermCrntIsValid As Boolean
  Dim PermTable() As Variant
  Dim PointsTotalCrnt As Long
  Dim PointsTotalLowest As Long
  Dim PosnNumCrnt1 As Long
  Dim PosnNumCrnt2 As Long
  Dim PppTable As Variant
  'Dim RowNotTop200Crnt As Long
  Dim RowPermCrnt As Long
  Dim RowPermCrntMax As Long
  Dim RowPermLowestTotal As Long
  Dim RowPppCrnt() As Long
  Dim RowPppMax() As Long
  Dim RowPppMaxMax As Long
  'Dim RowRepeatCrnt As Long
  'Dim RowTooHighCrnt As Long
  Dim TimeStart As Single

  TimeStart = Timer   ' Seconds since midnight

  Application.ScreenUpdating = False

  With Worksheets("PlayerPerPosition")

    ColPppMax = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column

    NumPosns = ColPppMax / 2       ' I ought to check there are an even number of columns

    ReDim RowPppMax(1 To NumPosns)

    RowPppMaxMax = 0
    PosnNumCrnt1 = 1
    For ColPppCrnt = 2 To ColPppMax Step 2
      RowPppMax(PosnNumCrnt1) = .Cells(Rows.Count, ColPppCrnt).End(xlUp).Row
      If RowPppMaxMax < RowPppMax(PosnNumCrnt1) Then
        ' If this position has more rows than any previous position, record new maximum row
        RowPppMaxMax = RowPppMax(PosnNumCrnt1)
      End If
      PosnNumCrnt1 = PosnNumCrnt1 + 1
    Next

    PppTable = .Range(.Cells(1, 1), .Cells(RowPppMaxMax, ColPppMax)).Value

  End With

   ' Initialise current row table
  ReDim RowPppCrnt(1 To NumPosns)
  For PosnNumCrnt1 = 1 To NumPosns
    RowPppCrnt(PosnNumCrnt1) = RowPppDataFirst
  Next

  ' Size arrays to hold current permutation prior to validation and
  ' the 200 permutation with the highest permitted totals.
  ' Note with 2D arrays it is conventional for the first dimension to
  ' be for columns and the second dimension to be for rows.  Arrays
  ' holded from ranges or to be loaded to ranges are the other way
  ' round.
  ReDim PermCrnt(1 To NumPosns)
  ReDim PermTable(1 To 200, 1 To NumPosns + 1)     ' Extra column for total

  NumPermsGenerated = 0
  RowPermCrntMax = 0
  'RowTooHighCrnt = 0
  'RowRepeatCrnt = 0
  'RowNotTop200Crnt = 0

  'Worksheets("Too High").Cells.EntireRow.Delete     ' Delete any previous output
  'Worksheets("Repeat").Cells.EntireRow.Delete
  'Worksheets("Not Top 200").Cells.EntireRow.Delete
  'Worksheets("Permutations").Cells.EntireRow.Delete

  Do While True

    ' Generate current permulation from indices
    PermCrntIsValid = True  ' Assume current permutation is valid until find otherwise
    PointsTotalCrnt = 0
    ColPppCrnt = 1
    For PosnNumCrnt1 = 1 To NumPosns
      PermCrnt(PosnNumCrnt1) = PppTable(RowPppCrnt(PosnNumCrnt1), ColPppCrnt)
      ColPppCrnt = ColPppCrnt + 1
      PointsTotalCrnt = PointsTotalCrnt + PppTable(RowPppCrnt(PosnNumCrnt1), ColPppCrnt)
      ColPppCrnt = ColPppCrnt + 1
    Next
    NumPermsGenerated = NumPermsGenerated + 1

    ' Check points total not higher than maximum
    If PointsTotalCrnt > PointsTotalMaxPermitted Then
      PermCrntIsValid = False
      'RowTooHighCrnt = RowTooHighCrnt + 1
      'If RowTooHighCrnt < 65537 Then
      '  With Worksheets("Too High")
      '    For PosnNumCrnt1 = 1 To NumPosns
      '      .Cells(RowTooHighCrnt, PosnNumCrnt1) = PermCrnt(PosnNumCrnt1)
      '    Next
      '    .Cells(RowTooHighCrnt, NumPosns + 1) = PointsTotalCrnt
      '  End With
      'End If
    End If

    ' Check player not repeated
    If PermCrntIsValid Then
      For PosnNumCrnt1 = 1 To NumPosns - 1
        For PosnNumCrnt2 = PosnNumCrnt1 + 1 To NumPosns
          If PermCrnt(PosnNumCrnt1) = PermCrnt(PosnNumCrnt2) Then
            ' Same player in two positions
            PermCrntIsValid = False
            Exit For
          End If
        Next
        If Not PermCrntIsValid Then
          'RowRepeatCrnt = RowRepeatCrnt + 1
          'If RowRepeatCrnt < 65537 Then
          '  With Worksheets("Repeat")
          '    For PosnNumCrnt2 = 1 To NumPosns
          '      .Cells(RowRepeatCrnt, PosnNumCrnt2) = PermCrnt(PosnNumCrnt2)
          '    Next
          '    .Cells(RowRepeatCrnt, NumPosns + 1) = PointsTotalCrnt
          '  End With
          'End If
          Exit For
        End If
      Next
    End If

    If PermCrntIsValid Then
      If RowPermCrntMax < UBound(PermTable, 1) Then
        ' Permutations table is not full so save current permulation in
        ' next available row.
        RowPermCrntMax = RowPermCrntMax + 1
        For PosnNumCrnt1 = 1 To NumPosns
          PermTable(RowPermCrntMax, PosnNumCrnt1) = PermCrnt(PosnNumCrnt1)
        Next
        PermTable(RowPermCrntMax, NumPosns + 1) = PointsTotalCrnt
        If RowPermCrntMax = 1 Then
          ' This is first permutation to be saved.  Record as lowest
          PointsTotalLowest = PointsTotalCrnt
          RowPermLowestTotal = RowPermCrntMax
        Else
          ' Check for new lowest total
          If PointsTotalLowest > PointsTotalCrnt Then
            PointsTotalLowest = PointsTotalCrnt
            RowPermLowestTotal = RowPermCrntMax
          End If
          If RowPermCrntMax = UBound(PermTable, 1) Then
            ' Have just filled Permutations table
            With Worksheets("Permutations")
             .Range(.Cells(1, 1), _
                    .Cells(UBound(PermTable, 1), NumPosns + 1)).Value = PermTable
            End With
          End If
        End If
      Else
        ' Permutations table is full so only save current permulation
        ' if its points total is greater than lowest in table
        If PointsTotalCrnt > PointsTotalLowest Then
          ' Replace permutation with lowest total with with current permutation
          For PosnNumCrnt1 = 1 To NumPosns
            PermTable(RowPermLowestTotal, PosnNumCrnt1) = PermCrnt(PosnNumCrnt1)
          Next
          PermTable(RowPermLowestTotal, NumPosns + 1) = PointsTotalCrnt
          ' Find new lowest total
          ' Initialise lowest from first row in table then search rest of table
          PointsTotalLowest = PermTable(1, NumPosns + 1)
          RowPermLowestTotal = 1
          For RowPermCrnt = 2 To UBound(PermTable, 1)
            If PointsTotalLowest > PermTable(RowPermCrnt, NumPosns + 1) Then
              PointsTotalLowest = PermTable(RowPermCrnt, NumPosns + 1)
              RowPermLowestTotal = RowPermCrnt
            End If
          Next
        Else
          'RowNotTop200Crnt = RowNotTop200Crnt + 1
          'If RowNotTop200Crnt < 65537 Then
          '  With Worksheets("Not Top 200")
          '    For PosnNumCrnt1 = 1 To NumPosns
          '      .Cells(RowNotTop200Crnt, PosnNumCrnt1) = PermCrnt(PosnNumCrnt1)
          '    Next
          '    .Cells(RowNotTop200Crnt, NumPosns + 1) = PointsTotalCrnt
          '    .Cells(RowNotTop200Crnt, NumPosns + 2) = PermTable(RowPermLowestTotal, NumPosns + 1)
          '  End With
          'End If
        End If  ' Current permutation to replace lowest
      End If  ' Permutation table full
    End If  ' PermCrntIsValid

    ' Generate next permulation index
    GenerationFinished = True     ' Assume finishe until find otherwise
    For PosnNumCrnt1 = 1 To NumPosns
      If RowPppCrnt(PosnNumCrnt1) < RowPppMax(PosnNumCrnt1) Then
        RowPppCrnt(PosnNumCrnt1) = RowPppCrnt(PosnNumCrnt1) + 1
        GenerationFinished = False
        Exit For
      End If
      RowPppCrnt(PosnNumCrnt1) = RowPppDataFirst
    Next
    If GenerationFinished Then
      Exit Do
    End If

  Loop  ' until all permutation have been generated

  With Worksheets("Permutations")

    .Cells.EntireRow.Delete     ' Delete any previous output

    ' Generate header row
    RowPermCrnt = 1
    PosnNumCrnt1 = 1   ' Uses as column number for Permutations worksheets
    For ColPppCrnt = 1 To ColPppMax Step 2
      .Cells(RowPermCrnt, PosnNumCrnt1).Value = PppTable(RowPppPosnName, ColPppCrnt)
      PosnNumCrnt1 = PosnNumCrnt1 + 1
    Next
    With .Cells(RowPermCrnt, NumPosns + 1)
      .Value = "Total"
      .HorizontalAlignment = xlRight
    End With
    .Range(.Cells(1, 1), .Cells(1, NumPosns + 1)).Font.Bold = True

    RowPermCrnt = RowPermCrnt + 1

     ' Write Permutation table to worksheet
    .Range(.Cells(2, 1), _
           .Cells(UBound(PermTable, 1) + 1, NumPosns + 1)).Value = PermTable

  End With

  Debug.Print "Duration " & Format(Timer - TimeStart, "##0.00")
  Debug.Print "Number of permutations generated " & NumPermsGenerated

End Sub