arrays - 如何根据满足特定条件的列将 2 列数组的值分配给单列数组

Question

我需要制作一个宏，从 A 列收集部件号，并每隔 8 个空格将它们粘贴到另一张纸上。问题是我需要根据订单代码执行此操作:A11、A21、A31、B11、B21、B31、C11、C21、C31、C12、C22、C32、C13、C23、C33(位于 B 列)每个表，有 5 个表，分组如下:表“A##”包含所有以“A”开头的代码。工作表“B##”包含所有带“B”的代码。工作表“C#1”包含所有以 C 开头并以 1 结尾的代码，依此类推。这需要为大约 12000 个零件完成。根据我对 Excel VBA 的了解，我相信数组是完成此任务的最快方法。

订单代码的示例是“A11”、“A12”、“A13”，这 3 个代码需要发送到另一张纸。我使用通配符来限制过滤(即“A**”代表“A13”、“A23”等)。

下面是我目前用来完成此任务的代码，以及其他宏和所有循环，第一次运行宏花了我 1 小时 5 分钟。但是，此宏需要每月运行一次并使用相同的工作簿，因此我运行了第二次以“刷新”数据，耗时 3.5 小时。现在它不再运行了，所以我不得不寻找其他方法来加速它。

在下面的代码中，wb = 事件工作簿，Sht 是我要将代码放在其中的工作表。我这样写是因为我正在将它作为一个 excel 插件，而不仅仅是工作簿中的一个模块。

Public Sub SetupSheetA()
Set wb = ActiveWorkbook
Set Sht = wb.Worksheets("A##")
Code = "A**"
'Grab endRow value for specific sheet designated by the order code
With wb.Worksheets("SO Hits Data Single Row")
    endRow = 1 + 8 * Application.WorksheetFunction.CountIf(.Range("B4:B999999"), Code)
End With
Sht.Cells.Clear 'Clear sheet contents

'Macros
    Call PartInfo

    'Other macros not relevant to this question

End Sub

Public Sub PartInfo()
'***********************************************************************************************************
'Collect Part #, order code, vendor info, and WH Info
'***********************************************************************************************************
Dim j As Long, i As Long
j = Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A999999"))
With Sht
    'Part #
    CurrentPartRow = 2
    For i = 4 To j
        If Sheets("SO Hits Data Single Row").Range(Cells(i, 2).Address) Like Code Then
            .Range(Cells(CurrentPartRow, 1).Address).Value = "='SO Hits Data Single Row'!" & Cells(i, 1).Address
            CurrentPartRow = CurrentPartRow + 8
        End If
    Next i
    'Order code
    .Range("A3").Value = "=VLOOKUP(A2,'SO Hits Data Single Row'!$A:$B,2,FALSE)"
'Copy to Next Row
    For CurrentPartRow = 10 To endRow - 7 Step 8
        'Order code CopyPaste
        .Range("A3").Copy Destination:=.Range(Cells(CurrentPartRow + 1, 1).Address
    Next CurrentPartRow
End With
End Sub

我试图通过将工作簿另存为 .xlbs 来加快速度，这将文件大小从 240MB 减少到 193MB。然后我删除了所有我可以逃脱的数据并删除了任何不必要的格式，这些格式进一步将文件减少到 163MB，然后删除宏正在粘贴数据的工作表将文件减少到 73MB。即使使用这个小得多的文件，尽管运行了整个周末，宏仍然会挂起并且没有响应。

我还尝试使用这段代码过滤数组:

Dim arr1 As Variant, arr2 As Variant, i As Long, code As String

code = "A**" 'For any order codes containing A11, A12, A13, A21, A22, _
A23, etc

Lastrow = Sheets("SO Hits Data Single Row").Cells(Rows.Count, _
1).End(xlUp).Row

arr1 = Sheets("SO Hits Data Single Row").Range("B4:B" & Lastrow).Value
arr2 = Filter(arr1, code)
Sheets("A##").Range("a1") = arr2

但它只是给出了一个不匹配的错误。

下面是我需要实现的输出示例。

Answer 1

如果您有 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 获取前缀，并根据订单代码SORTing。

然后我们通过将结果从动态公式转换为静态值来“扁平化”结果。