VBA將數據行轉換為列

[英]VBA transpose rows of data into columns


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行,在正常行之間,我有一些信息,需要轉換成行。作為示例,此信息如下所示:

enter image description here

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

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

5 个解决方案

#1


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


1  

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


1  

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


0  

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:

transpose col

#5


0  

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

如果刪除行,最好從下到上創建一個新的工作表或循環


注意!

本站翻译的文章,版权归属于本站,未经许可禁止转摘,转摘请注明本文地址:https://www.itdaan.com/blog/2015/10/06/7201f60c2c676f479a736b0405703af2.html



 
粤ICP备14056181号  © 2014-2020 ITdaan.com