获取数据行并转换成连续行的列

我见过一些类似的post，但不是我需要或可以理解解决我的简单问题。

我有数百行的数据，我想转换成列。 原始数据就像这样，两行之间有空行，相关数据的长度可以变化：

9 8 7 6 5 4 3 2 1 J I H G FE D C B A 

我想能够颠倒每个集合的顺序，然后转置他们在每个数据集的另一行，如下所示：

 1 2 3 4 5 6 7 8 9 ABCDEFGHIJ 

我使用一个简单的公式= OFFSET（$ A $ 2，COUNTA（A：A）-ROW（），0）获得了一些成功，因为我不确定如何在VBA中实现。

我用来获取所有数据然后转置的代码，我无法让它为每一个唯一的数据集连续下来。 这是我正在尝试使用的代码，但它似乎并没有工作，只是开始运行下来的工作表，直到macros伸出。

 Sub TransposeRange() Dim InRange As Range Dim OutRange As Range Dim i As Long Set InRange = Sheets("Output").Range("A3:A10002") Set OutRange = Sheets("Output").Range("H2:NTR2") For i = 1 To 10000 Step 1 OutRange.Cells(1, i) = InRange.Cells(i, 1) ActiveCell.Offset(1, 0).Select Next i End Sub 

我确定有一些明显而简单的东西我错过了，但是唉，我还是训练中的一个小菜鸟。 任何build议将不胜感激。

Answer 1

这段代码假设你的数据是常量，并且使用VBA的精彩的SpecialCells属性来分解第1列中的每个块。它还使用了一个数组，它比循环单元快得多：

 Sub TransposeColumnSections() Dim ws As Excel.Worksheet Dim LastRow As Long Dim ColumnConstants As Excel.Range Dim i As Long Dim ColumnArea As Excel.Range Dim AreaRowsCount As Long Dim ReversedConstants() As Variant Dim j As Long Set ws = ActiveSheet With ws LastRow = .Range("A" & .Rows.Count).End(xlUp).Row Set ColumnConstants = .Columns(1).SpecialCells(xlCellTypeConstants) For i = 1 To ColumnConstants.Areas.Count Set ColumnArea = ColumnConstants.Areas(i) AreaRowsCount = ColumnArea.Rows.Count ReDim ReversedConstants(1 To AreaRowsCount) For j = AreaRowsCount To 1 Step -1 ReversedConstants(AreaRowsCount - (j - 1)) = ColumnArea(j).Value Next j .Cells(i, 2).Resize(1, AreaRowsCount) = ReversedConstants Next i .Columns(1).Delete End With End Sub 

Answer 2

假设你的数据在列A，请尝试下面的使用sorting然后粘贴转置 ：（请改变表名称根据自己的）

 Sub sortNtranspose() Dim r As Integer Dim i As Integer Dim j As Integer Dim rn As Range r = Sheets("Sheet1").UsedRange.Rows.Count For i = 1 To r Set rn = Range(Cells(i, 1), Cells(Cells(i, 1).End(xlDown).Row, 1)) rn.Sort key1:=Cells(i, 1), order1:=xlAscending, Header:=xlNo Set rn = Range(Cells(i + 1, 1), Cells(Cells(i, 1).End(xlDown).Row, 1)) rn.Copy Cells(i, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True Do While Not IsEmpty(Cells(i, 1)) If IsEmpty(Cells(i, 2)) Then Cells(i, 2).EntireRow.Delete Else: i = i + 1 End If Loop r = Sheets("Sheet1").UsedRange.Rows.Count If j >= r Then Exit Sub End If j = Cells(i, 1).End(xlDown).Row i = j - 1 Next i End Sub