移動數據的某些行插入列

Question

如果我有這樣一個很長的列中的所有數據：

A 
B 
C 
1 
2 
3 

D 
E 
F 
4 
5 
6 

G 
H 
I 
7 
8 
9 

是否可以移動這樣的數據？

Column1 Column2 Column3 Column4 Column5 Column6 
A  B  C  1  2  3 
D  E  F  4  5  6 
G  H  I  7  8  9 

我試過特殊粘貼+轉，但我有10多個幾千條記錄，所以它會帶我太多的時間，使用此方法。

我是新來的excel和宏，非常感謝。

編輯：

我甚至試過所有的數據轉成多列，然後選擇我要讓他們都變成一列與此宏柱：

Sub OneColumn() 
' Jason Morin as amended by Doug Glancy 
' http://makeashorterlink.com/?M19F26516 
'''''''''''''''''''''''''''''''''''''''''' 
'Macro to copy columns of variable length 
'into 1 continuous column in a new sheet 
'''''''''''''''''''''''''''''''''''''''''' 

Dim from_lastcol As Long 
Dim from_lastrow As Long 
Dim to_lastrow As Long 
Dim from_colndx As Long 
Dim ws_from As Worksheet, ws_to As Worksheet 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Set ws_from = ActiveWorkbook.ActiveSheet 
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column 

'Turn error checking off so if no "AllData" trying to delete doesn't generate Error 
On Error Resume Next 
'so not prompted to confirm delete 
Application.DisplayAlerts = False 
'Delete if already exists so don't get error 
ActiveWorkbook.Worksheets("AllData").Delete 
Application.DisplayAlerts = True 
'turn error checking back on 
On Error GoTo 0 

'since you refer to "AllData" throughout 
Set ws_to = Worksheets.Add 
ws_to.Name = "AllData" 

For from_colndx = 1 To from_lastcol 
    from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row 
'If you're going to exceed 65536 rows 
If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then 
    to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row 
Else 
    MsgBox "This time you've gone to far" 
    Exit Sub 
End If 
ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _ 
    from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1) 
Next 

' this deletes any blank rows 
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

End Sub 

但它只是加入所有列成一列，但不是所選列。

對於Remou參考：

這裏是輸出：

A D G 

B E H 

C F I 

1 4 7 

2 5 8 

3 6 9 

Answer 1

你可以看的東西在這幾行：

Sub TransposeColumn() 
Dim rng As Range 
Dim ws As Worksheet 
Set rng = Worksheets("Input").UsedRange 
Set ws = Worksheets("Output") 
j = 1 
k = 1 
For i = 1 To rng.Rows.Count 
    If rng.Cells(i, 1) = vbNullString Then 
     j = j + 1 
     k = 1 
    Else 
     ''ws.Cells(k, j) = rng.Cells(i, 1) 
     ''EDIT 
     ws.Cells(j, k) = rng.Cells(i, 1) 
     k = k + 1 
    End If 
Next 

End Sub 

Answer 2

這是我如何做同樣的事情..它根據你的例子創建了C列中的新表格，每組數據之間有一個空白單元格：

Sub TransposeGroups() 
Dim RNG As Range, Grp As Long, NR As Long 

Set RNG = Range("A:A").SpecialCells(xlConstants) 
NR = 1 

    For Grp = 1 To RNG.Areas.Count 
     RNG.Areas(Grp).Copy 
     Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True 
     NR = NR + 1 
    Next Grp 

End Sub 

這應該適用於數據中任何長度的數據和高達8500的「組」。

這也使用AREAS方法，但是這通過使用子組克服了組限制，所以它應該適用於任何大小的數據集。

Sub TransposeGroups2() 
'Uses the AREAS method and will work on any size data set 
'overcomes the limitation of areas by working in subgroups 
Dim RNG As Range, rngSTART As Range, rngEND As Range 
Dim LR As Long, NR As Long, SubGrp As Long, Itm As Long 

LR = Range("A" & Rows.Count).End(xlUp).Row 
NR = 1 
SubGrp = 1 
Set rngEND = Range("A" & SubGrp * 10000).End(xlUp) 
Set RNG = Range("A1", rngEND).SpecialCells(xlConstants) 

Do 
    For Itm = 1 To RNG.Areas.Count 
     RNG.Areas(Itm).Copy 
     Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True 
     NR = NR + 1 
    Next Itm 


    If rngEND.Row = LR Then Exit Do 
    Set rngSTART = rngEND.Offset(1) 
    SubGrp = SubGrp + 1 
    Set rngEND = Range("A" & (SubGrp * 10000)).End(xlUp) 
    Set RNG = Range(rngSTART, rngEND).SpecialCells(xlConstants) 
Loop 

End Sub