[已解决]竖排变横排

张雄友

竖排变横排。

最佳答案

月排行榜 / 总排行榜

fffox

2014-1-5 15:12

这个比较简单啊

1. Sub 转换()
   
2.     Dim arr, brr()
   
3.     Dim i%, j%, k%, MaxCol%
   
4.     arr = Range("a1:b" & Cells(Rows.Count, 2).End(3).Row)
   
5.     ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr))
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 1) <> "" And arr(i, 1) <> arr(i - 1, 1) Then
   
8.             k = k + 1: j = 2
   
9.             brr(k, 1) = arr(i, 1)
   
10.             brr(k, 2) = arr(i, 2)
    
11.         ElseIf arr(i, 1) = "" Then
    
12.             j = j + 1
    
13.             brr(k, j) = arr(i, 2)
    
14.             If j > MaxCol Then MaxCol = j
    
15.         End If
    
16.     Next
    
17.     Range("e15").Resize(UBound(brr), UBound(brr, 2)).ClearContents
    
18.     Range("e15").Resize(k, MaxCol) = brr
    
19. End Sub

复制代码

跳转到最佳答案楼层

tgydslr

谢谢楼主分享，很好

张雄友

tgydslr 发表于 2014-1-5 14:35
谢谢楼主分享，很好

俺是求助，不是分享。

tgydslr

张雄友 发表于 2014-1-5 14:38
俺是求助，不是分享。

你那里面不是有竖排也有横排的吗
用函数自动生成的

fffox

这个比较简单啊

1. Sub 转换()
   
2.     Dim arr, brr()
   
3.     Dim i%, j%, k%, MaxCol%
   
4.     arr = Range("a1:b" & Cells(Rows.Count, 2).End(3).Row)
   
5.     ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr))
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 1) <> "" And arr(i, 1) <> arr(i - 1, 1) Then
   
8.             k = k + 1: j = 2
   
9.             brr(k, 1) = arr(i, 1)
   
10.             brr(k, 2) = arr(i, 2)
    
11.         ElseIf arr(i, 1) = "" Then
    
12.             j = j + 1
    
13.             brr(k, j) = arr(i, 2)
    
14.             If j > MaxCol Then MaxCol = j
    
15.         End If
    
16.     Next
    
17.     Range("e15").Resize(UBound(brr), UBound(brr, 2)).ClearContents
    
18.     Range("e15").Resize(k, MaxCol) = brr
    
19. End Sub

复制代码