[已解决]关于复制-粘贴-转置的问题，请有空的同学或老师帮忙看看，谢谢！

xhczq

附件有详细说明，谢谢！

最佳答案

月排行榜 / 总排行榜

xdragon

2013-11-8 10:38

1. Sub t()
   
2. Dim arr(), brr(), i&, j As Byte, r&, k&, m&
   
3. arr = Sheets("数据源").Range("A1").CurrentRegion.Value
   
4. r = UBound(arr, 2) * UBound(arr) + UBound(arr) - 1
   
5. ReDim brr(1 To 3, 1 To 1)
   
6. For i = 1 To UBound(arr)
   
7.   For j = 1 To UBound(arr, 2)
   
8.     If i Mod 2 = 1 Then
   
9.       m = m + 1
   
10.       ReDim Preserve brr(1 To 3, 1 To m)
    
11.       brr(1, m) = arr(i, j)
    
12.     Else
    
13.       brr(3, m - 5 + j) = arr(i, j)
    
14.     End If
    
15.   Next
    
16.   If i Mod 2 = 0 Then m = m + 1
    
17. Next
    
18. Sheets("希望的结果").Range("A1:C" & m - 1) = Application.Transpose(brr)
    
19. End Sub

复制代码

跳转到最佳答案楼层

xdragon

1. Sub t()
   
2. Dim arr(), brr(), i&, j As Byte, r&, k&, m&
   
3. arr = Sheets("数据源").Range("A1").CurrentRegion.Value
   
4. r = UBound(arr, 2) * UBound(arr) + UBound(arr) - 1
   
5. ReDim brr(1 To 3, 1 To 1)
   
6. For i = 1 To UBound(arr)
   
7.   For j = 1 To UBound(arr, 2)
   
8.     If i Mod 2 = 1 Then
   
9.       m = m + 1
   
10.       ReDim Preserve brr(1 To 3, 1 To m)
    
11.       brr(1, m) = arr(i, j)
    
12.     Else
    
13.       brr(3, m - 5 + j) = arr(i, j)
    
14.     End If
    
15.   Next
    
16.   If i Mod 2 = 0 Then m = m + 1
    
17. Next
    
18. Sheets("希望的结果").Range("A1:C" & m - 1) = Application.Transpose(brr)
    
19. End Sub

复制代码

xhczq

xdragon 发表于 2013-11-8 10:38

谢谢老师

xhczq

xdragon 发表于 2013-11-8 10:38

老师，为什么保存不了这VBA？

xhczq

xdragon 发表于 2013-11-8 10:38

我看错了，可以了，谢谢

xhczq

xdragon 发表于 2013-11-8 10:38

真不能保存，您能保存吗？

xdragon

xhczq 发表于 2013-11-8 11:20
真不能保存，您能保存吗？

不能保存？不会吧。。。。{:20:}你说不能撤销倒是真的。