转置区域值到另一区域中

wp8680

1. Sub 重排区域()
   
2.     Dim rng As Range, target As Range, arr, brr, a%, b%, x%, y%, R, S
   
3.     Dim k1%, k2%, m1%, m2%, k%
   
4.     On Error Resume Next
   
5. ok1:
   
6.     Set rng = Application.InputBox("请选择数据源区。", "提示：", , , , , , 8)
   
7.     If rng Is Nothing Then Err.Clear: GoTo ok1
   
8. ok2:
   
9.     Set target = Application.InputBox("请选择数据存放区。", "提示：", , , , , , 8)
   
10.     If target Is Nothing Then Err.Clear: GoTo ok2
    
11.     arr = rng.Value
    
12.     a = UBound(arr, 1)
    
13.     b = UBound(arr, 2)
    
14.     brr = target.Value
    
15.     x = UBound(brr, 1)
    
16.     y = UBound(brr, 2)
    
17.     m1 = 1
    
18.     m2 = 1
    
19.     If a * b > x * y Then MsgBox "你选择的存放区单元格数量小于数据源区，可能有部分数据不能显示！"
    
20.     R = MsgBox("数据源提取数据顺序，点“是”按行提取，点“否”按列提取", vbYesNo, "请选择数据提取顺序：")
    
21.     S = MsgBox("数据的存放顺序，点“是”按行存放，点“否”按列存放", vbYesNo, "请选择数据存放顺序：")
    
22.     For k1 = 1 To IIf(R = 6, a, b)
    
23.         For k2 = 1 To IIf(R = 6, b, a)
    
24.             k = k + 1
    
25.             If k > x * y Then Exit For
    
26.             brr(IIf(S = 6, m1, m2), IIf(S = 6, m2, m1)) = arr(IIf(R = 6, k1, k2), IIf(R = 6, k2, k1))
    
27.             m2 = m2 + 1
    
28.             If m2 = IIf(S = 6, y, x) Then m1 = m1 + 1: m2 = 1
    
29.         Next k2
    
30.     Next k1
    
31.     target.Value = brr
    
32. End Sub

复制代码

工作簿1.rar (18.09 KB, 下载次数: 17)

2014-6-30 14:45 上传

点击文件名下载附件 如题

tgydslr

这个不错