将所有值粘贴到匹配标题下的特定文本中

Question

在Sheet1上，我有一组数据，其中A列显示姓名，B列婚姻状况。 我想根据婚姻状况将名称输出到Sheet2，在那里我有一个预定的仪表板（A1可以是表格的开始）

数据集将是动态的，并且每次运行vba都会增长

我希望输出数据是什么

您能否协助此输出的VBA代码？ 非常感谢

*更新，这是我所拥有的代码...可以运行，但希望输入代码效率

Dim K As Long, r As Range, v As Variant
K = 1
Dim w1 As Worksheet, w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
w1.Activate
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
    v = r.Value
    If InStr(v, "Divorced") > 0 Then 
        r.Offset(, -1).Copy w2.Cells(K + 3, 2)
        K = K + 1
    End If
Next r
K = 1
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
    v = r.Value
    If InStr(v, "Married") > 0 Then
        r.Offset(, -1).Copy w2.Cells(K + 3, 3)
        K = K + 1
    End If
Next r
K = 1
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
    v = r.Value
    If InStr(v, "Single") > 0 Then
        r.Offset(, -1).Copy w2.Cells(K + 3, 4)
        K = K + 1
    End If
Next r
K = 1
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
    v = r.Value
    If InStr(v, "Widowed") > 0 Then
        r.Offset(, -1).Copy w2.Cells(K + 3, 5)
        K = K + 1
    End If
Next r

Answer 1

如果您正在寻找最好的编码方式，这就是我的方法。这在11秒内运行了大约一百万行数据。代码注释清楚。必要时调整变量值以匹配您的实际数据。

编辑：添加了变量，以允许wsDest上的输出列从定义的列开始，而不是假设列A。将其设置为B以匹配OP的代码。

Sub tgr()

    Const lDataHeaderRow As Long = 1    'The header row of your 2-column original data worksheet
    Const lDestHeaderRow As Long = 1    'The header row of your multi-column destination/output worksheet
    Const sDestStartCol As String = "B" 'The column letter where the output results begin

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rDestHeaders As Range
    Dim hResults As Object
    Dim aData As Variant
    Dim aResults() As Variant
    Dim vTemp As Variant
    Dim i As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("Sheet1")
    Set wsDest = wb.Worksheets("Sheet2")
    Set rDestHeaders = wsDest.Range(wsDest.Cells(lDestHeaderRow, sDestStartCol), wsDest.Cells(lDestHeaderRow, wsDest.Columns.Count).End(xlToLeft))
    Set hResults = CreateObject("Scripting.Dictionary") 'Use a dictionary to keep track of marital statuses and associated names

    'Define your data range here and load it into a variant array for processing
    With wsData.Range("A" & lDataHeaderRow + 1, wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
        If .Row <= lDataHeaderRow Then Exit Sub   'No data
        ReDim aResults(1 To Evaluate("MAX(COUNTIF('" & wsData.Name & "'!B:B,'" & wsDest.Name & "'!" & rDestHeaders.Address & "))"), 1 To rDestHeaders.Cells.Count)
        aData = .Value
    End With

    'Define which column is for which header, the "|0" is the starting count found for that marital status
    For i = 1 To rDestHeaders.Cells.Count
        hResults(LCase(Trim(rDestHeaders.Cells(, i).Value))) = i & "|" & 0
    Next i

    'Loop through the variant array, looking at column 2 for the status
    For i = LBound(aData, 1) To UBound(aData, 1)
        'Verify column 1 and 2 and aren't blank
        If Len(Trim(aData(i, 1))) > 0 And Len(Trim(aData(i, 2))) > 0 Then
            'Verify current marital status (column 2) is listed in the destination headers
            If hResults.Exists(LCase(Trim(aData(i, 2)))) Then
                vTemp = Split(hResults(LCase(Trim(aData(i, 2)))), "|")
                vTemp(1) = vTemp(1) + 1
                aResults(vTemp(1), vTemp(0)) = aData(i, 1)
                hResults(LCase(Trim(aData(i, 2)))) = Join(vTemp, "|")
            End If
        End If
    Next i

    'Clear previous results
    Intersect(wsDest.Cells(lDestHeaderRow, sDestStartCol).CurrentRegion, rDestHeaders.EntireColumn).Offset(1).ClearContents

    'Output results
    wsDest.Cells(lDestHeaderRow + 1, sDestStartCol).Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults

End Sub