转置数据（重新排列）

Question

我正在尝试重新排列大数据集，并认为VBA是实现此目的的最佳，最有效的方法。

我有一个与此结构类似的数据集：

并根据这些数据，尝试获取以下输出：

有人写过什么来做这种事情吗？对于这些建议或建议，我将不胜感激。

非常感谢，

Answer 1

转置数据（重新排列）

调整常量部分中的值以适合您的需求。

链接

Workbook Download (Dropbox)

图片

来源（第1张）

目标1 （第2张）

目标2 （第3张）

ID不会发生，因为像上一版本中的Ted一样，找不到它。

版本1

Sub TransposeData1()

    ' Source
    Const cSource As String = "Sheet1"  ' Worksheet Name
    Const cFR As Long = 2               ' First Row Number
    Const cFRC As Variant = "A"         ' First-Row Column Letter/Number
    Const cRep As String = "B"          ' Repeat Columns Range Address
    Const cUni As String = "C:G"        ' Unique Columns Range Address

    ' Target
    Const cTarget As String = "Sheet2"  ' Worksheet Name
    Const cHeaders As String = "IDDiff,Supervisor,Primary,Secondary"
    Const cSupervisor As String = "Ted" ' Supervisor
    Const cFCell As String = "A1"       ' First Cell Range Address

    ' Source
    Dim rng As Range      ' First-Row Column Last Used Cell Range
    Dim vntR As Variant   ' Repeat Array
    Dim vntU As Variant   ' Unique Array
    Dim NoR As Long       ' Number of Records

    ' Target
    Dim vntH As Variant   ' Header Array
    Dim vntT As Variant   ' Target Array
    Dim CUR As Long       ' Current Column
    Dim i As Long         ' Target Array Row Counter
    Dim j As Long         ' Target/Repeat Array Column Counter
    Dim k As Long         ' Repeat/Unique Array Row Counter
    Dim m As Long         ' Unique Array Column Counter

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    On Error GoTo ProcedureExit

    ' In Source Worksheet
    With ThisWorkbook.Worksheets(cSource).Columns(cFRC)
        ' In First-Row Column
        With .Columns(cFRC)
            ' Calculate First-Row Column Last Used Cell Range.
            Set rng = .Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious)
            ' Check if no data in First-Row Column.
            If rng Is Nothing Then
                MsgBox "No data in column '" _
                        & Split(.Cells(1).Address, "$")(1) & "'."
                GoTo ProcedureExit
            End If
            ' Calculate Number of Records needed to calculate Repeat Range
            ' and Unique Range.
            NoR = rng.Row - cFR + 1
        End With
        ' In Repeat Columns
        With .Columns(cRep)
            ' Copy calculated Repeat Range to Repeat Array.
            vntR = .Cells(1).Offset(cFR - 1).Resize(NoR, .Columns.Count)
        End With
        ' In Unique Columns
        With .Columns(cUni)
            ' Copy calculated Unique Range to Unique Array.
            vntU = .Cells(1).Offset(cFR - 1).Resize(NoR, .Columns.Count)
        End With
    End With

    ' In Arrays

    ' Resize Target Array:
    '   Rows
    '     1                     - for Headers.
    '     NoR * Ubound(vntU, 2) - for data.
    '   Columns
    '     1               - for IDs.
    '     1               - for Supervisor.
    '     UBound(vntR, 2) - for Repeat Array Columns.
    '     1               - for unique values.
    ReDim vntT(1 To 1 + NoR * UBound(vntU, 2), _
            1 To 1 + 1 + UBound(vntR, 2) + 1)

    ' Headers to Header Array
    vntH = Split(cHeaders, ",")

    ' Header Array to Target Array
    For j = 1 To UBound(vntT, 2)
        vntT(1, j) = Trim(vntH(j - 1))
    Next

    ' IDs to Target Array
    CUR = CUR + 1 ' Calculate Current Column in Target Array.
    For i = 2 To UBound(vntT)
        vntT(i, CUR) = i - 1
    Next

    ' Supervisor to Target Array
    CUR = CUR + 1 ' Calculate Current Column in Target Array.
    For i = 2 To UBound(vntT)
        vntT(i, CUR) = cSupervisor
    Next

    ' Repeat Array to Target Array
    CUR = CUR + 1 ' Calculate Current Column in Target Array.
    i = 1 ' First row of Target Array contains Headers.
    ' Task: Write values of current rows (k) in columns (j) in Repeat Array
    ' to current rows (i) in columns (j + CUR - 1) of Target Array as many
    ' times as there are columns (m) in Unique Array.
    For k = 1 To UBound(vntR) ' Rows of Repeat Array
        For m = 1 To UBound(vntU, 2) ' Columns of Unique Array
            i = i + 1 ' Count current row of Target Array.
            For j = 1 To UBound(vntR, 2) ' Columns of Repeat Array
                ' Write value of current record in Repeat Array
                ' to current record of Target Array.
                vntT(i, j + CUR - 1) = vntR(k, j)
            Next
        Next
    Next

    ' Unique Array to Target Array
    CUR = CUR + UBound(vntR, 2) ' Calculate Current Column in Target Array.
    i = 1 ' First row of Target Array contains Headers.
    ' Task: Write values of current row (k) and current column (m) of Unique
    ' Array each to the next row (i) in current column (CUR) of Target Array.
    For k = 1 To UBound(vntU) ' Rows of Unique Array
        For m = 1 To UBound(vntU, 2) ' Columns of Unique Array
            i = i + 1 ' Count current row of Target Array.
            ' Write value of current record in Unique Array
            ' to current record of Target Array.
            vntT(i, CUR) = vntU(k, m)
        Next
    Next

    ' In Target Worksheet
    With ThisWorkbook.Worksheets(cTarget).Range(cFCell)
        ' Clear contents of Target Range and the range below it.
        .Resize(.Parent.Rows.Count - .Parent.Range(cFCell).Row + 1, _
                UBound(vntT, 2)).ClearContents
        ' Copy Target Array to Target Range.
        .Resize(UBound(vntT), UBound(vntT, 2)) = vntT
    End With

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

版本2

Sub TransposeData2()

    ' Source
    Const cSource As String = "Sheet1"  ' Worksheet Name
    Const cFR As Long = 2               ' First Row Number
    Const cFRC As Variant = "A"         ' First-Row Column Letter/Number
    Const cRep As String = "A:B"        ' Repeat Columns Range Address
    Const cUni As String = "C:G"        ' Unique Columns Range Address
    Const cUH As Long = 1               ' Unique Header Row Number

    ' Target
    Const cTarget As String = "Sheet3"  ' Worksheet Name
    Const cHeaders As String = "ID,Primary,Secondary,Relationship"
    Const cFCell As String = "A1"       ' First Cell Range Address

    ' Source
    Dim rng As Range      ' First-Row Column Last Used Cell Range
    Dim vntR As Variant   ' Repeat Array
    Dim vntU As Variant   ' Unique Array
    Dim NoR As Long       ' Number of Records

    ' Target
    Dim vntH As Variant   ' Header Array
    Dim vntT As Variant   ' Target Array
    Dim vntUH As Variant  ' Unique Header Array
    Dim CUR As Long       ' Current Column
    Dim i As Long         ' Target Array Row Counter
    Dim j As Long         ' Target/Repeat Array Column Counter
    Dim k As Long         ' Repeat/Unique Array Row Counter
    Dim m As Long         ' Unique/Unique Header Array Column Counter

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    On Error GoTo ProcedureExit

    ' In Source Worksheet
    With ThisWorkbook.Worksheets(cSource).Columns(cFRC)
        ' In First-Row Column
        With .Columns(cFRC)
            ' Calculate First-Row Column Last Used Cell Range.
            Set rng = .Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious)
            ' Check if no data in First-Row Column.
            If rng Is Nothing Then
                MsgBox "No data in column '" _
                        & Split(.Cells(1).Address, "$")(1) & "'."
                GoTo ProcedureExit
            End If
            ' Calculate Number of Records needed to calculate Repeat Range
            ' and Unique Range.
            NoR = rng.Row - cFR + 1
        End With
        ' In Repeat Columns
        With .Columns(cRep)
            ' Copy calculated Repeat Range to Repeat Array.
            vntR = .Cells(1).Offset(cFR - 1).Resize(NoR, .Columns.Count)
        End With
        ' In Unique Columns
        With .Columns(cUni)
            ' Copy calculated Unique Range to Unique Array.
            vntU = .Cells(1).Offset(cFR - 1).Resize(NoR, .Columns.Count)
            ' Copy calculated Unique Header Range to Unique Header Array.
            vntUH = .Cells(1).Offset(cUH - 1).Resize(, .Columns.Count)
        End With
    End With

    ' In Arrays

    ' Resize Target Array:
    '   Rows
    '     1                     - for Headers.
    '     NoR * Ubound(vntU, 2) - for data.
    '   Columns
    '     UBound(vntR, 2) - for Repeat Array Columns.
    '     1               - for unique values.
    '     1               - for Unique Header Row.
    ReDim vntT(1 To 1 + NoR * UBound(vntU, 2), _
            1 To UBound(vntR, 2) + 1 + 1)

    ' Write Headers to Header Array.
    vntH = Split(cHeaders, ",")
    ' Write Headers to Target Array.
    For j = 1 To UBound(vntT, 2)
        vntT(1, j) = Trim(vntH(j - 1))
    Next

    ' Repeat Array to Target Array
    CUR = CUR + 1 ' Calculate Current Column in Target Array.
    i = 1 ' First row of Target Array contains Headers.
    ' Task: Write values of current rows (k) in columns (j) in Repeat Array
    ' to current rows (i) in columns (j + CUR - 1) of Target Array as many
    ' times as there are columns (m) in Unique Array.
    For k = 1 To UBound(vntR) ' Rows of Repeat Array
        For m = 1 To UBound(vntU, 2) ' Columns of Unique Array
            i = i + 1 ' Count current row of Target Array.
            For j = 1 To UBound(vntR, 2) ' Columns of Repeat Array
                ' Write value of current record in Repeat Array
                ' to current record of Target Array.
                vntT(i, j + CUR - 1) = vntR(k, j)
            Next
        Next
    Next

    ' Unique Array to Target Array
    CUR = CUR + UBound(vntR, 2) ' Calculate Current Column in Target Array.
    i = 1 ' First row of Target Array contains Headers.
    ' Task: Write values of current row (k) and current column (m) of Unique
    ' Array each to the next row (i) in current column (CUR) of Target Array.
    For k = 1 To UBound(vntU) ' Rows of Unique Array
        For m = 1 To UBound(vntU, 2) ' Columns of Unique Array
            i = i + 1 ' Count current row of Target Array.
            ' Write value of current record in Unique Array
            ' to current record of Target Array.
            vntT(i, CUR) = vntU(k, m)
        Next
    Next

    ' Unique Header Array to Target Array
    CUR = CUR + 1 ' Calculate Current Column in Target Array.
    i = 1 ' First row of Target Array contains Headers.
    ' Task: Write values of current column (m) of Unique Header Array each
    ' to the next row (i) in current column (CUR) of Target Array as many
    ' times as there are rows(k) in Unique Array.
    For k = 1 To UBound(vntU) ' Rows of Unique Array
        For m = 1 To UBound(vntUH, 2) ' Columns of Unique Header Array
            i = i + 1 ' Count current row of Target Array.
            ' Write value of current record in Unique Array
            ' to current record of Target Array.
            vntT(i, CUR) = vntUH(1, m)
        Next
    Next

    ' In Target Worksheet
    With ThisWorkbook.Worksheets(cTarget).Range(cFCell)
        ' Clear contents of Target Range and the range below it.
        .Resize(.Parent.Rows.Count - .Parent.Range(cFCell).Row + 1, _
                UBound(vntT, 2)).ClearContents
        ' Copy Target Array to Target Range.
        .Resize(UBound(vntT), UBound(vntT, 2)) = vntT
    End With

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Answer 2

您可以循环浏览名称，然后将其输出到列中。可能类似于以下内容：

Option Explicit
Sub sort()
Dim rArea As Range, lRow As Long, oCN As Long, outCol As String, cell As Range
'Set this to the range of names
Set rArea = ActiveSheet.Range("C2:G4")
'Set this to output
outCol = "J"

oCN = Columns(outCol).Column
For Each cell In rArea
    lRow = ActiveSheet.Range(outCol & ActiveSheet.Rows.Count).End(xlUp).Row 'Update last row in output column
    Cells(lRow + 1, oCN).Value = cell.Value                                 'Print Name
    Cells(lRow + 1, oCN - 1).Value = Cells(cell.Row, 2).Value               'Print Company
Next cell
End Sub

我在最后时刻做了一些动态更改。但是与图片进行比较，您应该就能弄清楚我在做什么。

我看不到要在其他行中添加宏的意义，但是显然您也可以这样做。

重新排列单元格Excel VBA

2 个答案:

转置数据（重新排列）

链接

图片

版本1

版本2