excel - 重新排列单元格Excel VBA

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