VBA将数据行转换为列

I googled this question, but nothing reasonalbe didn't pop out, and i don't have any clue, at the moment, how to do it. So, decided to write here.

我用Google搜索了这个问题,但没有任何理由没有弹出,我现在也没有任何线索,如何做到这一点。所以,决定写在这里。

I have large table, aprox. 300'000 rows, and between normal rows, i have some information, which needs to be transposed to rows. As a sample, this information looks like this:

我有大桌子,aprox。 300'000行,在正常行之间,我有一些信息,需要转换成行。作为示例,此信息如下所示:

If any ideas pops out, please, let me know. Best regards.

如果有任何想法,请告诉我。最好的祝福。

5 个解决方案

#1

With so much data, I felt the process would execute more rapidly, as Jeeped mentioned, done in VBA arrays instead of on the worksheet. Here is a macro that does that. To tell where to start a new row, I looked at column 2 -- if column 2 is blank, then the data is appended to the previous row; if not, then a new row would start.

有了这么多的数据,我觉得这个过程会像Jeeped所说的那样在VBA数组而不是在工作表上完成。这是一个宏。为了告诉从哪里开始新行,我查看了第2列 - 如果第2列为空,则将数据附加到上一行;如果没有,那么将开始一个新行。

Other types of testing could be substituted.

其他类型的测试可以替代。

---

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

---

#2

300,000 rows is going to take some time to process but this may run through fairly quickly.

300,000行需要一些时间来处理,但这可能会很快完成。

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

Faster processing could likely be achieved with processing variant memory arrays but this should get the job done.

处理变体存储器阵列可能会实现更快的处理,但这应该可以完成工作。

#3

I liked Jeeped solution, but it seems to reorder the data witch might not be desired. Here is my proposed solution, I haven't benchmarked so I can't tell if it is really slower.

我喜欢Jeeped解决方案,但它似乎重新排序可能不需要的数据。这是我提出的解决方案,我没有基准,所以我不知道它是否真的慢。

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

I've come up with another version mixing Jeeped and mine:

我想出了混合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

#4

You can use the PasteSpecial function with Transpose:=True. For example:

您可以将PasteSpecial函数与Transpose:= True一起使用。例如:

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

would transpose A2:A5 to E2:

将A2:A5转换为E2:

#5

First define which rows have to be Transposed! Is there only the first row filled with values? Or are the values numeric? Is the result in a new or the same worksheet?

首先定义哪些行必须转置!是否只有第一行填充了值?或者值是数字?结果是新的还是相同的工作表?

You can use a for loop from first row to last row:

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

Find out the Cell where the transposed range is inserted. Then check which ranges have to be transposed. Use long variables for the first and last row You want to transpose. When a new row with values comes, cut the range and paste it into the desired cell

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

U can use the the macro recorder to see how to transpose a range. Or Look at the other answers.

你可以使用宏录制器来查看如何移调范围。或者看看其他答案。

If you delete the rows it is better to create a new Worksheet or Loop from bottom to Top

如果删除行,最好从下到上创建一个新的工作表或循环