Pasting all values with specific text under matching header - excel

Question

On Sheet1, I have a set of data with column A showing names and column B marital status.
I would like to output the name based on the marital status to Sheet2 where I have a predetermined dashboard (A1 could be start of table)
The data set will be dynamic and grow each time the vba is run
what I'd like the output data to be
Would you kindly assist in the vba code for this output?
Update, here is the code I have...which works but would like input on code efficiency
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

If you're looking for the best way to code it, here's how I would do it. This ran about a million rows of data in 11 seconds. Code commented for clarity. Adjust the variable values to match your actual data where necessary.
EDIT: Added variable to allow for output column on wsDest to begin at defined column instead of assuming column A. Set it to B to match OP's code.
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