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.

Could you elaborate on this `9 of 45 codes` (share a list) and on this `Set Sht = wb.Worksheets("A##"): Code = "A**"`? Also, describe in which worksheets this is happening, what the `VLOOKUP` formula is doing, etc. Be more specific. You can [edit your post](https://stackoverflow.com/posts/71564805/edit) at any time. — VBasic2008, Mar 21 '22 at 22:43
Which part of the code takes the time and hangs? Have you set `Application.Calculation` to `xlCalculationManual` to pause Calculations while the code is running? Also, is there any data between the output Part Numbers, or is it "value1, 7 blank lines, value2, 7 blank lines…"? Image of Output would help to make this a [mcve] — Chronocidal, Mar 21 '22 at 23:01
Sorry, still don't get it. You have posted this screenshot that has 13 value pairs. Could you share the name of the worksheet and the worksheet names and cell addresses of where these 13 value pairs need to be copied to? — VBasic2008, Mar 21 '22 at 23:02
Trying to keep things simple, I have made it unclear. My apologies. I updated with the output I am trying to achieve. I have managed this with a very crude macro that hangs when I am gathering the part numbers to go on each sheet (Sheet "A##" shown in the last screenshot I added). There are 5 sheets: "A##", "B##", "C#1", "C#2", "C#3" which grab part numbers from "SO Hits Data Single Row". As for which codes go on what sheet, the "#" symbols in the sheet name is basically a wildcard and could be any number with the other digits being constant (i.e. "C#3" should grab C13, C23, and C33 codes. — CodeNewbie, Mar 22 '22 at 14:11

score 2 · Answer 1 · answered Mar 21 '22 at 23:36

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.

I have attempted using this with the inputs "A", "A##" and "A**" but I haven't received anything but FALSE. Also to clarify it is Excel 365. — CodeNewbie, Mar 22 '22 at 14:37

score 2 · Accepted Answer · answered Mar 28 '22 at 16:12

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

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

2 Answers2