VBA如何把多列转成一列格式？

czr0373

详见附件，原数据多列排列，转换后变成一列排列！

vbee

1. Sub vbee()
   
2. arr = Sheets("源").Range("a1").CurrentRegion
   
3. r = UBound(arr) - 1
   
4. For i = 2 To UBound(arr, 2)
   
5.   brr = Sheets("源").Cells(2, 1).Resize(r)
   
6.   crr = Sheets("源").Cells(2, i).Resize(r)
   
7.    rr = (i - 2) * r + 1
   
8.    Sheets("转后").Cells(rr, 1).Resize(r) = arr(1, i)
   
9.    Sheets("转后").Cells(rr, 2).Resize(r) = brr
   
10.    Sheets("转后").Cells(rr, 3).Resize(r) = crr
    
11. Next i
    
12. End Sub

复制代码

lsc900707

1. Sub gj23w98()
   
2.     Dim brr(1 To 10000, 1 To 3)
   
3.     arr = Sheet1.[a1].CurrentRegion
   
4.     For j = 2 To UBound(arr, 2)
   
5.         For i = 2 To UBound(arr)
   
6.             If Len(arr(i, j)) Then
   
7.                 m = m + 1
   
8.                 brr(m, 1) = arr(1, j)
   
9.                 brr(m, 2) = arr(i, 1)
   
10.                 brr(m, 3) = arr(i, j)
    
11.             End If
    
12.         Next
    
13.     Next
    
14.     If m Then [a2].Resize(m, 3) = brr
    
15. End Sub

复制代码

lsc900707

附件供测试：

乐乐2006201505

Sub Macro1()
    Dim arr, brr(), i&
    arr = Sheets(1).Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr) * 3 - 3, 1 To 3)
    For i = 2 To UBound(arr)
        brr(i - 1, 1) = arr(1, 2)
        brr(i - 1, 2) = arr(i, 1)
        brr(i - 1, 3) = arr(i, 2)
        brr(i - 2 + 16, 1) = arr(1, 3)
        brr(i - 2 + 16, 2) = arr(i, 1)
        brr(i - 2 + 16, 3) = arr(i, 3)
        brr(i - 3 + 32, 1) = arr(1, 4)
        brr(i - 3 + 32, 2) = arr(i, 1)
        brr(i - 3 + 32, 3) = arr(i, 4)
    Next
    With Sheets("sheet1")
        .UsedRange.Offset(1).ClearContents
        .Range("C2:C" & UBound(arr)).NumberFormatLocal = "0.0_ "
        .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    End With
End Sub自己的办法太笨，本来有和版主一样的思路，不过功力太浅，无法达到。下面代码是在版主代码基础上修改的，一起上传，方便自己以后使用。
Sub gj23w98()
    Dim brr
    arr = Sheet1.[a1].CurrentRegion
    ReDim brr(1 To UBound(arr) * 3 - 3, 1 To 3)
    For j = 2 To UBound(arr, 2)
        For i = 2 To UBound(arr)
            If Len(arr(i, j)) Then
                m = m + 1
                brr(m, 1) = arr(1, j)
                brr(m, 2) = arr(i, 1)
                brr(m, 3) = arr(i, j)
            End If
        Next
    Next
    With Sheets("sheet1")
        .UsedRange.Offset(0).ClearContents
        .Range("b1") = arr(1, 1)
        .Range("C2:C" & UBound(arr) * 3 - 2).NumberFormatLocal = "0.0_ "
        If m Then .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    End With
End Sub

jiminyanyan

有结果了。。。