vba - 如何将一个或多个列对转置到 Excel 中的匹配记录？

Question

给定这样的数据集：

Sheet 1

Col1           Col2         Col3
Miss Molly     Extra Data   Extra Data
Mister Rogers  Extra Data   Extra Data
Roy Rogers     Extra Data   Extra Data

和

Sheet 2

Col1           Col2           Col3
Miss Molly     Value Name 1   Value Data 1
Miss Molly     Value Name 2   Value Data 2
Mister Rogers  Value Name 1   Value Data 1
Roy Rogers     Value Name 1   Value Data 1
Roy Rogers     Value Name 2   Value Data 2
Roy Rogers     Value Name 3   Value Data 3

我怎样才能得到这样的转置输出？

Sheet X (you can make me a new sheet if you like, or add to Sheet 1)

Col1           Col2         Col3        Col4           Col5          Col6          Col7          Col8          Col9
Miss Molly     Extra Data   Extra Data  Value Name 1   Value Data 1  Value Name 2  Value Data 2
Mister Rogers  Extra Data   Extra Data  Value Name 1   Value Data 1  
Roy Rogers     Extra Data   Extra Data  Value Name 1   Value Data 1  Value Name 2  Value Data 2  Value Name 3    Value Data 3

Answer 1

尝试这个

Sub MergeData()
    Dim rSrc As Range
    Dim rDst As Range
    Dim rwSrc As Range
    Dim rwDst As Range
    Dim vSrc As Variant, vCopy As Variant
    Dim cl As Range
    Dim i As Long

    Set rDst = ActiveWorkbook.Sheets("Sheet1").UsedRange
    vSrc = ActiveWorkbook.Sheets("Sheet2").UsedRange
    ReDim vCopy(1 To 1, 1 To 2)
    Application.FindFormat.Clear

    For i = 1 To UBound(vSrc, 1)
        If vSrc(i, 1) <> "" Then
            ' Find vSrc(i, 1) in rDst.Column(1)
            Set cl = rDst.Columns(1).Find( _
                What:=vSrc(i, 1), _
                After:=rDst.Cells(1, 1), _
                LookIn:=xlFormulas, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlNext, _
                MatchCase:=False, _
                SearchFormat:=False)

            ' Copy data to Dest sheet
            If Not cl Is Nothing Then
                Set cl = cl.End(xlToRight).Offset(0, 1)
                vCopy(1, 1) = vSrc(i, 2)
                vCopy(1, 2) = vSrc(i, 3)
                cl.Resize(1, 2) = vCopy
            Else
                ' Name not found in Dest sheet
            End If
        End If
    Next
End Sub