Question

我在表1中有以下格式的数据：

我想在下面的表2中重新组织数据： “标识符”的长度将是动态的我已经尝试使用循环和复制范围构建用于转置的宏，但还没有成功。任何帮助是极大的赞赏。

Answer 1

如果我理解你所追求的是什么，这里有一个宏。当它启动时，它会要求您选择源数据的左上角（默认为活动单元格），然后它会询问目标的左上角 - 当选择框启动时，您可以选择具有鼠标，如果您不想输入它。将此代码放在模块中：

Sub TransposeByLastColumn()

'get the top left corner of the source
Dim Source As Range
On Error Resume Next
Set Source = Application.InputBox("Select Source:", "Source", "=" & ActiveCell.Address, Type:=8)
On Error GoTo 0
If Source Is Nothing Then Set Source = ActiveCell

'get the top left corner of the destination
Dim Destination As Range
On Error Resume Next
Set Destination = Application.InputBox("Select Destination:", "Destination", Type:=8)
On Error GoTo 0
If Destination Is Nothing Then Exit Sub

'calculate the number of headers
Dim HeaderColumns As Long
HeaderColumns = 0
While Source.Offset(0, HeaderColumns).Value <> vbNullString
    HeaderColumns = HeaderColumns + 1
Wend

'copy the headers
Dim HeaderIndex As Long
Destination.Offset(0, 0).Value = Source.Offset(0, HeaderColumns - 1).Value
For HeaderIndex = 1 To HeaderColumns - 1
    Destination.Offset(0, HeaderIndex).Value = Source.Offset(0, HeaderIndex - 1).Value
Next

'copy the data
Dim SourceRowIndex As Long
Dim DestinationRowIndex As Long
Dim DataColumnIndex As Long
Dim IdentifierColumnIndex As Long
SourceRowIndex = 1
DestinationRowIndex = 1
While Source.Offset(SourceRowIndex, HeaderColumns - 1).Value <> vbNullString
    IdentifierColumnIndex = 1
    While Source.Offset(SourceRowIndex, HeaderColumns - 1 + IdentifierColumnIndex - 1).Value <> vbNullString
        Destination.Offset(DestinationRowIndex, 0).Value = Source.Offset(SourceRowIndex, HeaderColumns - 1 + IdentifierColumnIndex - 1).Value
        For DataColumnIndex = 1 To HeaderColumns - 1
            Destination.Offset(DestinationRowIndex, DataColumnIndex).Value = Source.Offset(SourceRowIndex, DataColumnIndex - 1).Value
        Next
        IdentifierColumnIndex = IdentifierColumnIndex + 1
        DestinationRowIndex = DestinationRowIndex + 1
    Wend
    SourceRowIndex = SourceRowIndex + 1
Wend

'show the result
Destination.Worksheet.Activate: Destination.Select

End Sub

Answer 2

这很有效。但你必须重新安排最终的结果＆＃39;列移动＆＃34;标识符＆＃34;列到结果集的开头。

Sub test()

    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim A, B, R, C As Long
    Dim x() As Variant
    Dim y() As Variant

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")

    With ws

        Range("A1").Select

        A = Range("A" & Rows.Count).End(xlUp).Row
        x = Range("A1", "I" & A)
        y = Range("J1", "Z" & A)


        For R = 1 To UBound(y, 1)
            B = R + 0
            For C = 1 To UBound(y, 2)
                If (y(R, C)) <> "" Then
                    Range("A" & B, "H" & B).Copy
                    Range("A" & A + 1).PasteSpecial
                    Application.CutCopyMode = False
                    Range("I" & A + 1).Value = y(R, C)
                    A = A + 1
                Else
                GoTo xxx:
                End If

            Next C
xxx:
        Next R

        Range("A1").Select

    End With

End Sub

Excel - 将动态列转换为不同工作表中的行并复制必要的数据项

2 个答案: