How to assign values from a 2 column array to a single column array based on a column meeting certain criteria

Question

I need to make a macro that will gather part numbers from column A and paste them onto another sheet every 8 spaces. The catch is that I need to do this based on order codes: A11, A21, A31, B11, B21, B31, C11, C21, C31, C12, C22, C32, C13, C23, C33 (located in column B) per sheet, There are 5 sheets that are grouped as follows: Sheet 'A##' contains all codes starting with "A". Sheet 'B##' contains all codes with "B". Sheet 'C#1' contains all codes starting with C and ending with 1 and so on. This needs to be done for roughly 12000 parts. From the little knowledge I have of Excel VBA, I believe an array is the fastest way to accomplish this.

An example of what the order code looks like would be "A11", "A12", "A13" for the 3 codes needing to be sent to another sheet. I have used the wildcards symbol to limit the filtering (i.e. "A**" to represent "A13", "A23", etc.).

Below is the code I currently use to accomplish this task and with the other macros and all the looping the first run of the macro took me 1h 5 min. However, this macro will need to be run once a month and with the same workbook so I ran a second time to "refresh" the data and that took 3.5 hours. Now it won't run anymore so I have had to look for other ways to speed it up.

In the following code wb = active workbook and Sht is the sheet I want the codes onto. I wrote it this way because I am making this an excel add-in rather than just a module within the workbook.

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

I have tried to speed things up by saving the workbook as .xlbs which reduced the file size from 240MB to 193MB. I then deleted all the data I could get away with and removed any unnecessary formatting that further reduced the file to 163MB and then deleting the sheets the macro is pasting data onto reduced the file to 73MB. Even with this much smaller file the macro will still hang and not respond despite running it over the entire weekend.

I also tried to filter the array using this code:

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

But it just gives a mismatch error.

Below is a sample of the output I need to achieve.

Answer 1

So, I have found that an array was in fact the best way to approach this. However, The file size was clearly a major issue, and I found it was due to blank cells being included in the current selection. Once I fixed that the macro ran quicker but still took too long. I ended up writing code to save the data to an array and then filter it later in a similar fashion to the following.

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

The above code is a little more specific to my situation but below is a more general form for any future viewers.

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

Answer 2

If you have Excel 2019 or Excel 365, then you can use the built-in SORT and FILTER functions to greatly simplify things:

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

Basically, we fill the first column of the destination sheet with a function that will be blank for 7 lines (IF(MOD(ROW()+6,8)>0,), then provide the next entry (INDEX(.., (ROW()+6)/8, 1)) in an array that we get by FILTERing for the Prefix, and SORTing on the Order Code.

Then we "flatten" the result by converting it from dynamic formulae into static values.