[已解决]另类转换有合并单元的情况

张雄友

另类转换有合并单元的情况.

最佳答案

月排行榜 / 总排行榜

xdragon

2014-8-10 13:51

1. Sub 下标的()
   
2. TT = Timer
   
3. Dim arr, i&, j&, m&
   
4. arr = [A1].CurrentRegion
   
5. ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
   
6. For i = 2 To UBound(arr) Step 2
   
7.       For j = 2 To UBound(arr, 2)
   
8.          If Len(arr(i, j)) Then
   
9.          m = m + 1
   
10.          brr(m, 1) = arr(1, j)
    
11.          brr(m, 2) = arr(i, 1)
    
12.          brr(m, 3) = arr(i, j)
    
13.          brr(m, 4) = arr(i + 1, j)
    
14.          End If
    
15.       Next
    
16. Next
    
17. [O:R].ClearContents
    
18. '[O2].Resize(m, 4) = brr
    
19. [O2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
20. MsgBox "用时" & Format(Timer - TT, "0.00") & "秒"
    
21. End Sub

复制代码

你也别把代码改的面目全非吧。。。控制循环的step都被你删掉了。。。。还有你的if判断语句放到for j=1 to ubound(arr,2)外面，这个时候j=0，所以，arr(i,j)当然也就越界了。

跳转到最佳答案楼层

baksy

O2=MOD(ROW()-2,10)+1
P2=INDIRECT("a"&(INT((ROW()-2)/10)+1)*2)
Q2=OFFSET($A$1,MATCH(P2,A:A,)-1,MOD((ROW()-2),10)+1)
R2=OFFSET($A$1,MATCH(P2,A:A,),MOD((ROW()-2),10)+1)

全部下拉。

pengyx

如都是两两合并单元格就，就是一个算术问题

baksy

或
O2=MOD(ROW()-2,10)+1
P2=INDIRECT("a"&(INT((ROW()-2)/10)+1)*2)
Q2=OFFSET($A$1,MATCH($P2,$A:$A,)+(COLUMN()-18),MOD((ROW()-2),10)+1)

其中Q2公式横拉、下拉。

xdragon

1. 
   
2. Sub test()
   
3.    Dim arr, re(), i&, j%, cnt&
   
4.    arr = Range("A1").CurrentRegion.Value
   
5.    ReDim re(1 To (UBound(arr) - 1) / 2 * UBound(arr, 2), 1 To 4)
   
6.    For i = 2 To UBound(arr) Step 2
   
7.      For j = 2 To UBound(arr, 2)
   
8.         cnt = cnt + 1
   
9.         re(cnt, 1) = arr(1, j)
   
10.         re(cnt, 2) = arr(i, 1)
    
11.         re(cnt, 3) = arr(i, j)
    
12.         re(cnt, 4) = arr(i + 1, j)
    
13.      Next
    
14.    Next
    
15.    Range("AA2").Resize(UBound(re), UBound(re, 2)) = re
    
16. End Sub

复制代码

张雄友

xdragon 发表于 2014-8-10 12:45

黄色单元不显示怎么办？就是没有数据的不用显示。

xdragon

1. Sub test()
   
2.    Dim arr, re(), i&, j%, cnt&
   
3.    arr = Range("A1").CurrentRegion.Value
   
4.    ReDim re(1 To (UBound(arr) - 1) / 2 * UBound(arr, 2), 1 To 4)
   
5.    For i = 2 To UBound(arr) Step 2
   
6.      For j = 2 To UBound(arr, 2)
   
7.         If Len(arr(i, j)) Then
   
8.             cnt = cnt + 1
   
9.             re(cnt, 1) = arr(1, j)
   
10.             re(cnt, 2) = arr(i, 1)
    
11.             re(cnt, 3) = arr(i, j)
    
12.             re(cnt, 4) = arr(i + 1, j)
    
13.         End If
    
14.      Next
    
15.    Next
    
16.    Range("O2").Resize(UBound(re), UBound(re, 2)) = re
    
17. End Sub

复制代码

qh8600

张雄友 发表于 2014-8-10 13:00
黄色单元不显示怎么办？就是没有数据的不用显示。

加个判断

张雄友

xdragon 发表于 2014-8-10 13:12

怎么下标越界的？

xdragon

1. Sub 下标的()
   
2. TT = Timer
   
3. Dim arr, i&, j&, m&
   
4. arr = [A1].CurrentRegion
   
5. ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
   
6. For i = 2 To UBound(arr) Step 2
   
7.       For j = 2 To UBound(arr, 2)
   
8.          If Len(arr(i, j)) Then
   
9.          m = m + 1
   
10.          brr(m, 1) = arr(1, j)
    
11.          brr(m, 2) = arr(i, 1)
    
12.          brr(m, 3) = arr(i, j)
    
13.          brr(m, 4) = arr(i + 1, j)
    
14.          End If
    
15.       Next
    
16. Next
    
17. [O:R].ClearContents
    
18. '[O2].Resize(m, 4) = brr
    
19. [O2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
20. MsgBox "用时" & Format(Timer - TT, "0.00") & "秒"
    
21. End Sub

复制代码

你也别把代码改的面目全非吧。。。控制循环的step都被你删掉了。。。。还有你的if判断语句放到for j=1 to ubound(arr,2)外面，这个时候j=0，所以，arr(i,j)当然也就越界了。