[已解决]如何实现将一列数据转换成每8个一行排列？

sctianhang

如何实现将一列数据转换成每8个一行排列？
现在手上需要大量统计一个花名册，但是名字都是一列的，现在需要做一个表格，每8个一行排列，不知道该如何实现？

最佳答案

月排行榜 / 总排行榜

djyjysxxs

2013-10-30 19:32

Dim ar1(), ar2()
ar1 = 数据源区域.Value
ReDim ar2(1 To Int((UBound(ar1) + 7) / 8), 1 To 8)
r% = 1
c% = 1
For i% = 1 To UBound(ar1)
   ar2(r, c) = ar1(i, 1)
   c = c + 1
   If c > 8 Then
      r = r + 1
      c = 1
   End If
Next
目的区域.Resize(UBound(ar2), UBound(ar2, 2)) = ar2

跳转到最佳答案楼层

CheryBTL

方法很多，最好能将实际的文件压缩后发来，也方便测试。

djyjysxxs

Dim ar1(), ar2()
ar1 = 数据源区域.Value
ReDim ar2(1 To Int((UBound(ar1) + 7) / 8), 1 To 8)
r% = 1
c% = 1
For i% = 1 To UBound(ar1)
   ar2(r, c) = ar1(i, 1)
   c = c + 1
   If c > 8 Then
      r = r + 1
      c = 1
   End If
Next
目的区域.Resize(UBound(ar2), UBound(ar2, 2)) = ar2

mg0601001

我编了一个公式，请看附件。

张雄友

请看。

1. Sub 转换()
   
2. Dim ar1(), ar2()
   
3. Set 数据源区域 = [A1].CurrentRegion
   
4. ar1 = 数据源区域.Value
   
5. ReDim ar2(1 To Int((UBound(ar1) + 7) / 8), 1 To 8)
   
6. r% = 1
   
7. c% = 1
   
8. For i% = 1 To UBound(ar1)
   
9.    ar2(r, c) = ar1(i, 1)
   
10.    c = c + 1
    
11.    If c > 8 Then
    
12.       r = r + 1
    
13.       c = 1
    
14.    End If
    
15. Next
    
16. Set Rng = Application.InputBox("请选择存放区域起始单元格", "VBA", , , , , , 8)
    
17. If Rng Is Nothing Then Exit Sub
    
18. Rng.CurrentRegion.ClearContents
    
19. Rng.Resize(UBound(ar2), UBound(ar2, 2)) = ar2
    
20. End Sub
    

复制代码

张雄友

附件。

张雄友

修改一下。

1. Sub 转换()
   
2. Dim ar1(), ar2(), r&, c&, i&
   
3. Set 数据源区域 = Application.InputBox("请选择源区域", "VBA", , , , , , 8)
   
4. ar1 = 数据源区域.Value
   
5. LL = InputBox("请输入要转几列?", "VBA", 8)
   
6. If LL <> "" Then
   
7.    If LL > 256 Then
   
8.       MsgBox "2003版本不能满足设定的格式!"
   
9.       Exit Sub
   
10.    End If
    
11.    End If
    
12. ReDim ar2(1 To Int((UBound(ar1) + LL - 1) / LL), 1 To LL)
    
13. r& = 1
    
14. c& = 1
    
15. For i& = 1 To UBound(ar1)
    
16.    ar2(r, c) = ar1(i, 1)
    
17.    c = c + 1
    
18.    If c > LL Then
    
19.       r = r + 1
    
20.       c = 1
    
21.    End If
    
22. Next
    
23. Set Rng = Application.InputBox("请选择存放区域起始单元格", "VBA", , , , , , 8)
    
24. If Rng Is Nothing Then Exit Sub
    
25. Rng.CurrentRegion.ClearContents
    
26. Rng.Resize(UBound(ar2), UBound(ar2, 2)) = ar2
    
27. End Sub
    

复制代码

djyjysxxs

张雄友 发表于 2013-10-30 20:16
修改一下。

可以改来不要r和c么

张雄友

djyjysxxs 发表于 2013-10-30 20:21
可以改来不要r和c么

没到水平。

sctianhang

哈哈，多谢上面几位老兄支招，我测试一下！