Вставка всех значений с определенным текстом под соответствующим заголовком

Question

На Листе 1 у меня есть набор данных с колонкой А, показывающей имена и колонкой Б семейное положение.Я хотел бы вывести имя, основанное на семейном положении, на 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