如何根据满足特定条件的列将 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)) 在一个数组中，我们通过对前缀进行FILTERing，并对订单进行SORTing得到 。

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

Answer 2

所以，我发现数组实际上是解决这个问题的最佳方法。然而，文件大小显然是一个主要问题，我发现这是由于当前选择中包含空白单元格所致。一旦我修复了宏运行速度更快但仍然花费太长时间的问题。我最终编写了代码将数据保存到数组中，然后以与以下类似的方式对其进行过滤。

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