VBA将行数据转换为列

我search了这个问题，但是没有任何理由没有突然出现，目前我也没有任何线索。 于是，决定写在这里。

我有大桌子，aprox。 300'000行，和正常行之间，我有一些信息，这需要转置为行。 作为示例，这些信息如下所示：

如果有任何想法，请让我知道。 最好的祝福。

Answer 1

有了这么多的数据，我觉得这个过程会更快地执行，就像Jeeped所说的那样，在VBA数组中而不是在工作表上完成。 这是一个macros。 为了知道从哪里开始新行，我查看了第2列 – 如果第2列是空白的，那么数据被追加到前一行; 如果没有，那么一个新的行将开始。

其他types的testing可以被替代。

---

Option Explicit Sub TransposeSomeRows() Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range Dim vSrc As Variant, vRes() As Variant Dim I As Long, J As Long, K As Long Dim lRowCount As Long, lColCount As Long Set wsSrc = Worksheets("sheet1") Set wsRes = Worksheets("sheet2") Set rRes = wsRes.Cells(1, 1) With wsSrc.Cells lRowCount = .Find(what:="*", after:=.Item(1, 1), LookIn:=xlValues, _ searchorder:=xlByRows, searchdirection:=xlPrevious).Row lColCount = .Find(what:="*", after:=.Item(1, 1), _ searchorder:=xlByColumns, searchdirection:=xlPrevious).Column End With 'Read source data into array With wsSrc vSrc = .Range(.Cells(2, 1), .Cells(lRowCount, lColCount)) End With 'create results array 'Num of rows = number of items in Column 2 lRowCount = WorksheetFunction.CountA(wsSrc.Columns(2)) 'Num of columns = max of entries in a "start row" plus blanks to next "start row" lColCount = 0 For I = 1 To UBound(vSrc, 1) If vSrc(I, 2) <> "" Then For J = 1 To UBound(vSrc, 2) If vSrc(I, J) <> "" Then K = J Next J Else 'vSrc(i,2) = "" so add a column K = K + 1 End If lColCount = IIf(lColCount > K, lColCount, K) Next I ReDim vRes(1 To lRowCount, 1 To lColCount) 'Populate results array K = 0 For I = 1 To UBound(vSrc, 1) If vSrc(I, 2) <> "" Then K = K + 1 J = 1 For J = 1 To UBound(vSrc, 2) If vSrc(I, J) <> "" Then vRes(K, J) = vSrc(I, J) Else Exit For End If Next J Else vRes(K, J) = vSrc(I, 1) J = J + 1 End If Next I 'Write results to worksheet Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) With rRes .EntireColumn.Clear .Value = vRes .EntireColumn.AutoFit End With End Sub 

---

Answer 2

30万行将需要一些时间来处理，但这可能会相当快速地运行。

 Sub duplicate() Dim rw As Long, nrw As Long Application.ScreenUpdating = False With Worksheets("Sheet1") '<~~ set this worksheet properly! For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If Not IsNumeric(.Cells(rw, 1).Value2) Then nrw = Application.Match(1E+99, .Cells(1, 1).Resize(rw - 1, 1)) .Cells(nrw, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 1).Value2 .Rows(rw).Delete Else With .Rows(rw) .Cells.Sort Key1:=.Cells(1), Order1:=xlAscending, _ Orientation:=xlLeftToRight, Header:=xlNo End With End If Next rw End With Application.ScreenUpdating = True End Sub 

处理不同的存储器arrays可能会获得更快的处理速度，但这应该能够完成工作。

Answer 3

我喜欢Jeeped解决scheme，但它似乎重新排列可能不需要的数据。 这是我提出的解决scheme，我没有进行基准testing，所以我不知道它是否真的很慢。

 Public Sub Test() Dim lastRow As Long, firstRow As Long, lastCell As Range, rng As Range Dim currentRow As Long Application.ScreenUpdating = False lastRow = Cells(Rows.Count, 1).End(xlUp).Row For currentRow = lastRow To 1 Step -1 If IsNumeric(Cells(currentRow, 1).Value) Then Set lastCell = Cells(currentRow, 1).End(xlToRight).Offset(0, 1) Set rng = Range(Cells(firstRow, 1), Cells(lastRow, 1)) rng.Copy lastCell.PasteSpecial Transpose:=True rng.EntireRow.Delete lastRow = currentRow - 1 Else firstRow = currentRow End If Next currentRow Application.ScreenUpdating = False End Sub 

我想出了另一个版本混合Jeeped和我的：

 Public Sub Test2(Optional ws As Worksheet) Dim lastRow As Long, lastCell As Range, rng As Range Dim currentRow As Long Application.ScreenUpdating = False If ws Is Nothing Then Set ws = ActiveSheet Dim BigestValue As Variant BigestValue = ws.Evaluate([MAX(A:A)]) lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row For currentRow = lastRow To 1 Step -1 If Not IsNumeric(ws.Cells(currentRow, 1).Value) Then 'look up for last numeric cell lastRow = currentRow currentRow = Application.Match(BigestValue, ws.Cells(1, 1).Resize(currentRow, 1)) Set lastCell = ws.Cells(currentRow, 1).End(xlToRight).Offset(0, 1) Set rng = Range(ws.Cells(currentRow + 1, 1), ws.Cells(lastRow, 1)) rng.Copy lastCell.PasteSpecial Transpose:=True rng.EntireRow.Delete End If Next currentRow Application.ScreenUpdating = True End Sub 

Answer 4

您可以将PasteSpecial函数与Transpose:=True 。 例如：

 Range("A2:A5").Select Selection.Copy Range("E1").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True 

将A2:A5转置为E2 ：

Answer 5

首先定义哪些行必须转置！ 是否只有第一行填充值？ 或者是数值？ 是在一个新的或相同的工作表中的结果？

您可以使用从第一行到最后一行的for循环：

找出插入换位范围的单元。 然后检查哪些范围必须转置。 对于第一行和最后一行使用长variables要转置。 当有值的新行时，剪切范围并将其粘贴到所需的单元格中

U可以使用macroslogging器来查看如何调换范围。 或者看看其他答案。

如果删除行，最好创build一个新的工作表或循环从底部到顶部