现有3或4或5或6或7或8或9或10或11或12支球队，进行单循环轮转，A1不动，逆时针旋转...

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim SH As Worksheet, lngRows As Long, lngStartID As Long
   
5.     Dim arrSource As Variant, lngID As Long
   
6.     Dim arrTeam As Variant, lngCount As Long
   
7.     Dim lngRowID As Long, lngColID As Long
   
8.     Dim rgResult As Range
   
9.    
   
10.     Set SH = Sheets("Sheet1")
    
11.     lngStartID = 7
    
12.     lngRows = SH.Range("A" & Rows.Count).End(xlUp).Row
    
13.     arrSource = SH.Range("A" & lngStartID & ":A" & lngRows)
    
14.     lngCount = lngRows - lngStartID + 1
    
15.     If lngCount < 3 Then
    
16.         MsgBox "一共就【" & lngCount & "】支队伍，你还想轮转？"
    
17.         Exit Sub
    
18.     End If
    
19.     '计算单列队伍数
    
20.     If lngCount Mod 2 = 1 Then lngCount = lngCount + 1
    
21.     lngRows = lngCount / 2
    
22.     '初始化轮转数组
    
23.     ReDim arrTeam(1 To lngRows, 1 To 2)
    
24.     For lngID = LBound(arrSource) To UBound(arrSource)
    
25.         lngRowID = ((lngID - 1) Mod lngRows) + 1
    
26.         lngColID = ((lngID - 1) \ lngRows) + 1
    
27.         arrTeam(lngRowID, lngColID) = arrSource(lngID, 1)
    
28.     Next
    
29.    
    
30.     '计算轮转次数
    
31.     lngCount = (lngRows - 1) * 2
    
32.     '设置初始填充单元格
    
33.     lngID = 1
    
34.     Set rgResult = SH.Range("D" & lngStartID)
    
35.     rgResult.Resize(Rows.Count - lngStartID, 2).Clear
    
36.    
    
37.     rgResult.Value = "第" & lngID & "轮"
    
38.     rgResult.Offset(1, 0).Resize(lngRows, 2) = arrTeam
    
39.    
    
40.     Set rgResult = rgResult.Offset(lngRows + 2, 0)
    
41.     For lngRowID = 1 To lngCount
    
42.         If TeamRotate(arrTeam) = True Then
    
43.             lngID = lngID + 1
    
44.             rgResult.Value = "第" & lngID & "轮"
    
45.             rgResult.Offset(1, 0).Resize(lngRows, 2) = arrTeam
    
46.             Set rgResult = rgResult.Offset(lngRows + 2, 0)
    
47.         End If
    
48.     Next
    
49. End Sub
    
50. 
    
51. '队伍轮转
    
52. Function TeamRotate(ByRef arrTeam As Variant) As Boolean
    
53.     Dim lngRows As Long, lngCols As Long
    
54.     Dim lngID As Long, strTemp As String
    
55.    
    
56.     lngRows = UBound(arrTeam)
    
57.     lngCols = UBound(arrTeam, 2)
    
58.     '如果传入的数组不足2行，不是2列，退出
    
59.     If lngRows < 2 Or lngCols <> 2 Then
    
60.         TeamRotate = False
    
61.         Exit Function
    
62.     End If
    
63.     '取出第一列最后一行的数据
    
64.     strTemp = arrTeam(lngRows, 1)
    
65.     '循环处理第一列
    
66.     For lngID = lngRows To LBound(arrTeam) + 1 Step -1
    
67.         arrTeam(lngID, 1) = arrTeam(lngID - 1, 1)
    
68.     Next
    
69.     '保持首位不变，第1列第2行取第2列第一行的数据
    
70.     arrTeam(LBound(arrTeam) + 1, 1) = arrTeam(LBound(arrTeam), 2)
    
71.     '循环处理第二列
    
72.     For lngID = LBound(arrTeam) To lngRows - 1
    
73.         arrTeam(lngID, 2) = arrTeam(lngID + 1, 2)
    
74.     Next
    
75.     '处理第2列最后1行
    
76.     arrTeam(lngRows, 2) = strTemp
    
77.    
    
78.     TeamRotate = True
    
79. End Function
    

复制代码

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, m, n, t
  Cells(7, "f").Resize(Rows.Count - 7, 2).ClearContents
  arr = Range("a7:a" & Cells(Rows.Count, "a").End(xlUp).Row)
  If UBound(arr, 1) Mod 2 > 0 Then '奇数处理
    arr = [a7].Resize(UBound(arr, 1) + 1)
    For i = UBound(arr, 1) To UBound(arr, 1) / 2 + 2 Step -1
      arr(i, 1) = arr(i - 1, 1)
    Next
    arr(i, 1) = "?"
  End If
  m = UBound(arr, 1) / 2
  ReDim brr(1 To m, 1 To 2)
  For i = 1 To UBound(arr, 1) - 1
    For j = 1 To m
      brr(j, 1) = arr(j, 1): brr(j, 2) = arr(m + j, 1)
    Next
    With Cells(7 + n, "f")
      .Value = Format(i, "第0轮")
      .Offset(1).Resize(m, 2) = brr
    End With
    n = n + m + 2: t = arr(m, 1)
    For j = m To 3 Step -1: arr(j, 1) = arr(j - 1, 1): Next
    arr(j, 1) = arr(m + 1, 1)
    For j = m + 1 To 2 * m - 1: arr(j, 1) = arr(j + 1, 1): Next
    arr(j, 1) = t
  Next
End Sub

YZC51

一把小刀闯天下 发表于 2019-6-12 19:37
Option Explicit

Sub test()

学习老师到代码。谢谢老师！！！
Sub test2()
  Dim arr, i, j, m, n, t
  Cells(7, "f").Resize(Rows.Count - 7, 2).ClearContents
  arr = Range("a7:a" & Cells(Rows.Count, "a").End(xlUp).Row)
  If UBound(arr, 1) Mod 2 > 0 Then '奇数处理
    arr = [a7].Resize(UBound(arr, 1) + 1)
    For i = UBound(arr, 1) To UBound(arr, 1) / 2 + 2 Step -1
      arr(i, 1) = arr(i - 1, 1)
    Next
    arr(i, 1) = "轮空"
  End If
  m = UBound(arr, 1) / 2
  ReDim brr(1 To m, 1 To 2)
  For i = 1 To UBound(arr, 1) - 1
    For j = 1 To m
'     Cells(i, 3) = j
   
    brr(j, 2) = Format(j, "第0场")
'      brr(j, 1) = arr(j, 1): brr(j, 2) = arr(m + j, 1)
      brr(j, 1) = arr(j, 1) & "→" & arr(m + j, 1)
    Next
    x = x + 1
    With Cells(7, x + 3)
      .Value = Format(i, "第0轮")
      .Offset(1).Resize(m, 2) = brr
    End With
    n = n + m + 2: t = arr(m, 1)
    For j = m To 3 Step -1: arr(j, 1) = arr(j - 1, 1): Next
    arr(j, 1) = arr(m + 1, 1)
    For j = m + 1 To 2 * m - 1: arr(j, 1) = arr(j + 1, 1): Next
    arr(j, 1) = t
  Next
End Sub