帮写个分组的代码，感谢

鬼才笑外

帮写个分组的代码

沈默00

觉得函数更简单些，， =WRAPCOLS(A1:A97,20,"")

wanao2008

看看是不是这个效果？

1. Sub byWanao()
   
2.     Dim i&, j&, k&, x&, y&, arr, brr
   
3.     arr = Range("A1").CurrentRegion
   
4.     Range("D1").CurrentRegion.Offset(1).ClearContents
   
5.     brr = Range("D1").CurrentRegion.Resize(UBound(arr))
   
6.     k = UBound(brr, 2)          'k = 不固定的组队数量
   
7.     For i = 1 To UBound(arr)
   
8.         x = (i - 1) \ k + 2
   
9.         y = (i - 1) Mod k + 1
   
10.         brr(x, y) = arr(i, 1)
    
11.     Next
    
12.     Range("D1").Resize(x, k) = brr
    
13. End Sub

复制代码

沈默00

沈默00

两种方法都有，，函数更为灵活，可以自己调整行数

longwin

Sub test()
arr = [A1].CurrentRegion
ds = [D1].End(xlToRight).Column - 3  '计算分成几队
[D1].CurrentRegion.Offset(1, 0).ClearContents
'ds = 5  '分成5队
zs = UBound(arr)    '总数
mds = Int(zs / ds) + 1 '每对人数
ReDim brr(1 To mds, 1 To ds)
For i = 1 To UBound(arr)
    m = Int((i - 1) / mds) + 1
    n = i Mod mds
    If n = 0 Then n = mds
    brr(n, m) = arr(i, 1)
Next
[d2].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

鬼才笑外

沈默00 发表于 2024-6-15 07:19
觉得函数更简单些，， =WRAPCOLS(A1:A97,20,"")

感谢，学到了一个公式

沈默00

优化一下，，可以自己输入每组的数量，，，再试一下