Как присвоить значения из массива из 2 столбцов массиву из одного столбца на основе столбца, соответствующего определенным критериям

Если у вас Excel 2019 или Excel 365, вы можете использовать встроенные функции SORT и FILTER, чтобы значительно упростить задачу:

Public Function PartsToSheet(OrderPrefix AS String) AS Boolean
    PartsToSheet = False
    On Error GoTo FuncErr 'Return False if there is an error
    Dim calcTMP As xlCalculation
    calcTMP = Application.Calculation
    'Only Calculate Formulae when we explicitly say to
    Application.Calculation = xlCalculationManual
    
    Dim wsSource AS Worksheet, wsDestination AS Worksheet
    Dim lParts AS Long, lRecords AS Long
    Dim adTable AS String, adOrders AS String
    
    Set wsSource = ThisWorkbook.Worksheets("SO Hits Data Single Row")
    Set wsDestination = ThisWorkbook.Worksheets(OrderPrefix & "##")
    
    'Prepare the Destination
    With wsDestination
        'Deleting Rows & Columns frees up the Used Range, freeing more memory than Clear does
        .Range(.Cells(1, 1), .Range(.Rows.Count, 1)).EntireRow.Delete
        .Range(.Cells(1, 1), .Range(1, .Columns.Count)).EntireColumn.Delete
    End With
    
    lParts = Application.CountA(wsSource.Columns(1))
    lRecords = Application.CountIf(wsSource.Columns(2), OrderPrefix & "*")
    
    adTable = wsSource.Range(wsSource.Cells(1, 1),wsSource.Cells(lParts, 2)).Address(True, True, xlA1, True)
    adOrders = wsSource.Range(wsSource.Cells(1, 2),wsSource.Cells(lParts, 2)).Address(True, True, xlA1, True)
    
    If lRecords > 0 Then 'If there are Order Codes for this Sheet
        wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Formula = _
            "=IF(MOD(ROW()+6,8)>0, """", INDEX(SORT(" & _
                "FILTER(" & adTable & ", LEFT(" & adOrders & ", 1) = """ & OrderPrefix & """)" & _
                ", 2), (ROW()+6)/8, 1))"
        
        wsDestination.Columns(1).Calculate 'Explicitly calculate formulae
        
        wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Value = _
            wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Value
    End If
    
    PartsToSheet = True 'Success!
FuncErr:
    On Error GoTo -1 'Clear any errors in the handler
    Application.Calculation = calcTMP
End Function

По сути, мы заполняем первый столбец целевого листа функцией, которая будет пустой для 7 строк (IF(MOD(ROW()+6,8)>0,), затем предоставляем следующую запись (INDEX(.., (ROW()+6)/8, 1)) в массиве, который мы получаем, FILTER для префикса и SORT для код заказа.

Затем мы «выравниваем» результат, преобразуя его из динамических формул в статические значения.

Итак, я обнаружил, что массив на самом деле был лучшим способом приблизиться к этому. Тем не менее, размер файла явно был серьезной проблемой, и я обнаружил, что это связано с тем, что пустые ячейки были включены в текущий выбор. Однажды я исправил, что макрос работал быстрее, но все равно занимал слишком много времени. В итоге я написал код, чтобы сохранить данные в массив, а затем отфильтровать их позже, как показано ниже.

Sub Example()

Dim arr1 As Variant, arr2(10000) As Variant, i As Long, j As Long, k As Long, Filter As String

Application.ScreenUpdating = False 'Freeze screen while macro runs
Application.EnableEvents = False 'Disable popups
Application.Calculation = xlManual 'Disable Sheet calcs

Filter = "A**"
arr1 = ActiveWorkbook.Worksheets("Sheet1").Range("A4:B12000").Value
j= Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A20000"))
    For i = 1 To j
        If arr1(i, 2) Like Filter Then
            arr2(k) = arr1(i, 1)
            arr2(k + 1) = ""
            arr2(k + 2) = ""
            arr2(k + 3) = ""
            arr2(k + 4) = ""
            arr2(k + 5) = ""
            arr2(k + 6) = ""
            arr2(k + 7) = ""
            k = k + 8 'This was so I could adjust for the blank spaces I needed between each value in the array
        End If
    Next i

Application.ScreenUpdating = True 'Unfreeze screen
Application.Calculation = xlAutomatic 'Enable Sheet calcs
Application.EnableEvents = True 'Enable popups

End Sub

Приведенный выше код немного более специфичен для моей ситуации, но ниже приведена более общая форма для будущих зрителей.

Sub Example()

Dim arr1 As Variant, arr2(10000) As Variant, i As Long, j As Long, k As Long, Filter As String

Application.ScreenUpdating = False 'Freeze screen while macro runs
Application.EnableEvents = False 'Disable popups
Application.Calculation = xlManual 'Disable Sheet calcs

Filter = "A**" 'This is where you would put your filter instead of "A**"
arr1 = ActiveWorkbook.Worksheets("Sheet1").Range("A4:B12000").Value
j= Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A20000"))
    For i = 1 To j
        If arr1(i, 2) Like Filter Then
            arr2(k) = arr1(i, 1)
        End If
    Next i

Application.ScreenUpdating = True 'Unfreeze screen
Application.Calculation = xlAutomatic 'Enable Sheet calcs
Application.EnableEvents = True 'Enable popups

End Sub