请问如何将一行的数据按规律转变成按列排列

MielOne

如附件，sheet1是原始的数据，希望运行宏之后变成sheet2这样
即只有AB两列数据，A列为班级，B列为班级对应的字母
实际情况数据量会很大，希望通过宏来实现，谢谢各位

123.rar (6.82 KB, 下载次数: 22)

2014-8-18 21:46 上传

点击文件名下载附件

dqhtju

1. Sub test()
   
2. 
   
3. 
   
4. Application.ScreenUpdating = False
   
5.     Dim rng As Range
   
6.     Dim lastCol As Integer
   
7.     Dim lastRow As Integer
   
8.    
   
9.     lastRow = [a65536].End(xlUp).Row
   
10.    
    
11.     j = 1923  '自行定义起始位置
    
12.     For i = 1 To lastRow
    
13.         lastCol = Cells(i, 1000).End(xlToLeft).Column
    
14.         Set rng = Range(Cells(i, 2), Cells(i, lastCol))
    
15.         Cells(j, 2).Resize(rng.Count, 1) = Application.WorksheetFunction.Transpose(rng.Value)
    
16.         Cells(j, 1).Resize(rng.Count, 1) = Cells(i, 1)
    
17.         j = j + rng.Count
    
18.         Set rng = Nothing
    
19.     Next
    
20.     Application.ScreenUpdating = True
    
21. 
    
22. 
    
23. End Sub

复制代码

hecm398

a = ActiveSheet.UsedRange.Rows.Count
    b = ActiveSheet.UsedRange.Columns.Count
    r = 1
    For i = 1 To a
       For j = 2 To b
       If Cells(i, j) <> "" Then
       Sheet2.Cells(r, 1) = Cells(i, 1)
       Sheet2.Cells(r, 2) = Cells(i, j)
       r = r + 1
       End If
       Next
       Next

1578278106

1. Sub test()
   
2.     Dim brr(1 To 100000, 1 To 2)
   
3.     arr = Range("a1").CurrentRegion
   
4.     For x = 1 To UBound(arr)
   
5.         For y = 2 To UBound(arr, 2)
   
6.             If arr(x, y) <> "" Then
   
7.                 n = n + 1
   
8.                 brr(n, 1) = arr(x, 1)
   
9.                 brr(n, 2) = arr(x, y)
   
10.             End If
    
11.         Next
    
12.     Next
    
13.     Sheet2.Range("a1").Resize(n, 2) = brr
    
14. End Sub
    

复制代码

1578278106

123.rar (17.42 KB, 下载次数: 26)

2014-8-18 23:22 上传

点击文件名下载附件

zax010

Sub zz()
    Application.ScreenUpdating = False
    With Sheet1
        For i = 1 To .[a1048576].End(3).Row
            lc = .Range("xfd" & i).End(xlToLeft).Column
            a = .Cells(i, 2).Resize(1, lc - 1)
        End With
        With Sheet2
            .Cells(1 + n, 1).Resize(UBound(a, 2), 1) = Cells(i, 1)
            .Cells(1 + n, 2).Resize(UBound(a, 2), 1) = Application.Transpose(a)
            n = n + UBound(a, 2)
        End With
    Next
    Application.ScreenUpdating = True
End Sub

zax010

>>>>>>>>>>>
123.rar (13.41 KB, 下载次数: 13)

2014-8-18 23:53 上传

点击文件名下载附件

楚乔chuqiao

学习了，好厉害呀