NOTE: I previously asked this question in Stack Overflow and got pointed here.
I have a macro that I am trying to get running a little more quickly. The intent of the macro is to merge multiple files into one. These files contain a unique ID for each item, some descriptive information about the item, and some measurement outcomes for each item. The measurement outcomes are what differ between the files.
In all the files, each item occupies a row, with the measurements in columns. No file lists all the items, but some items do appear in more than one file.
Currently, I iterate through the files and either use the data to update an existing row (for the items in a file that's already been processed), or create a new row if the item hasn't appeared in any previous file.
The place I'm losing a good chunk of time, especially on the later files, is finding the row for an item I've already added to the unified list, so that I can add the new measurement values to the appropriate column(s).
Public OldOName As String Public INotFnd As String Public FErr As String Function MMFProcessor(sfol As String, ifn As String, x As Integer, os As Worksheet, NPU As String, Prods As String, sw As StatWin, PM As String, _ FlgMeas() As String, m As Long, MKO As String, OName As String, Optional Ambetter As Boolean = False) As Variant() ' Dim src As Workbook Set src = Workbooks.Open(sfol & "\" & ifn & Right(Year(Now() - 25), 2) & "_.xlsx") Dim mks As String Dim mgc As String Dim sm As String Dim FMC As Boolean FMC = False 'want to only check that the filled length of FlgMeas & FMCol match once Dim ret As Boolean ret = True Dim RArr(3) As Variant Dim fnd As Boolean Dim y As Integer If sw.Detailed_Log Then Call Update("Starting MMFProcessor. Inputs: sfol= " & sfol & "; ifn= '" & ifn & "'; x= '" & x & "'; os= '" & os.Name & "'; m= '" & m & "'; MKO= '" & MKO & "'; OName= '" & OName & "'", 0, sw) End If 'Make sure we have as many values in the FlgMeas array's column values as in it's measure names (since they should be 1-1) If Not FMC Then If FilledLenS(FlgMeas(), sw, True, 0) = FilledLenS(FlgMeas(), sw, True, 2) Then FMC = True Else Call Err("The Flag Measures array does not have a column reference for each measure. This will result in either (or both) " _ & "some flag measures being set incorrectly, or missed entirely in the " & OName & " list. To prevent this, the list will not" _ & " be generated. Please contact the owner of this list generator found in cell B1 of the Main tab to have this issue addressed.", _ sw) ret = False End If End If If ret Then 'Filter based on ContrCnt & TermindationDate Call CC_TD(src.Worksheets(1)) 'Map the output columns to the source columns Dim ColDict() As String ReDim ColDict(x, 2) c = "A" Dim j As Integer j = 0 Do While os.Range(c & 1).Value <> "" And j < x And ret 'first two conditions should be redundant, but never hurts to be error proof Dim d As String fnd = False d = "A" 'c is always stored ColDict(j, 0) = c 'Find the match Do While src.Worksheets(1).Range(d & 1).Value <> "" And fnd = False If mks = "" Or mgc = "" Or sm = "" Then 'Also need to pull out MGC, MKS, & SM Select Case src.Worksheets(1).Range(d & 1).Value Case "ItemGroupCode" mgc = d Case "ItemKey" mks = d Case "SubMeasure" sm = d End Select End If If src.Worksheets(1).Range(d & 1).Value = os.Range(c & 1).Value Then 'Match, update the dictionary ColDict(j, 1) = d 'temp = src.Worksheets(1).Range(d & 1).Value fnd = True Else d = ColNumToStr(ColStrToNum(d) + 1) End If 'else no match, in the case a match is never found (CRM_Phone2) ColDict(j, 1) should be left blank (the default) Loop If Not fnd Then 'The field wasn't present in the Unedited file, but is that a problem? If InStr(1, LCase(NPU), "|" & LCase(os.Range(c & 1).Value) & "|") = 0 Then Call Err("The '" & os.Range(c & 1).Value & "' column was not found in the Unedited " & ifn & " file. As such the report will have no data in this column.", sw) End If 'else the field is calculated or not derived from QSI End If 'else the value was found and nothing needs done 'Increment c & j j = j + 1 c = ColNumToStr(j + 1) Loop 'MMA requires special cleaning since those items from that product aren't reported If ifn = "MMA" Then Call MMA_Clean(src.Worksheets(1), sw, mgc, sm) End If 'Iterate through the rows to output data Dim k As Long 'Source row being worked with Dim OutF As Boolean 'used to stop loop for flag column setting after column is found & set k = 2 Do While src.Worksheets(1).Range("A" & k).Value <> "" And ret 'Product match? 'Dim og As String 'og = src.Worksheets(1).Range(mgc & k).Value 'oz = InStr(1, LCase(src.Worksheets(1).Range(mgc & k).Value), "ambetter") If InStr(1, LCase(Prods), "|" & LCase(src.Worksheets(1).Range(mgc & k).Value) & "|") > 0 Or _ (Ambetter And InStr(1, LCase(src.Worksheets(1).Range(mgc & k).Value), "ambetter") > 0) Then 'Check if the user is new If InStr(1, PM, "|" & src.Worksheets(1).Range(mks & k).Value & "|") = 0 Then 'New add them to PM PM = PM & "|" & src.Worksheets(1).Range(mks & k).Value & "|" 'Output the item info For y = 0 To x 'UnMapped column? If ColDict(y, 1) <> "" Then 'Output the value os.Range(ColDict(y, 0) & m).Value = src.Worksheets(1).Range(ColDict(y, 1) & k).Value End If 'else the cell should be left blank, which is the default Next 'Set the appropriate flag column Call FlagSet(FlgMeas(), src, os, sm, k, m, sw, OName) 'Increment m m = m + 1 Else 'Find the item's prior row (in general it will be the last row filled, so we'll decrement rather then increment) Dim n As Long n = m - 1 fnd = False Do While n > 1 And fnd = False If os.Range(MKO & n).Value = src.Worksheets(1).Range(mks & k).Value Then 'Set the appropriate flag column Call FlagSet(FlgMeas(), src, os, sm, k, n, sw, OName) fnd = True Else n = n - 1 End If Loop If Not fnd Then 'post notice if we haven't already for this item and this file If OldOName <> OName Then 'Update OldOName and clear INotFnd OldOName = OName INotFnd = "" End If 'Check if item is in INotFnd (if we've changed files INotFnd will be empty) If InStr(1, INotFnd, "|" & src.Worksheets(1).Range(mks & k).Value & "|") = 0 Then Call Err("Item: " & src.Worksheets(1).Range(mks & k).Value & " is noted as already being present in the " & OName & " list, but" _ & " that row could not be located to update the item's non-compliance flags, meaning one or more of the flags will be incorrect" _ & ". Please be sure to make this change manually.", sw) INotFnd = INotFnd & "|" & src.Worksheets(1).Range(mks & k).Value & "|" End If 'else no need to repeat for same item End If End If End If 'non-<Products> users don't get reported k = k + 1 Loop End If 'else the arrays didn't match up and we've already notified the user 'Now we can close the workbook src.Close SaveChanges:=False 'Fill the return array RArr(0) = PM RArr(1) = m RArr(2) = ret MMFProcessor = RArr End Function
FlgMeas() is an array that maps the measurement columns' names to the column that measure should be output to;
mks is the column letter of the column that has the item IDs
As I mentioned at the beginning, this works, but it will sometimes have to iterate back through over 20k rows to find the right one. Currently that leaves the merge taking over 2 hrs, and I've just been directed to include more files (thus why I'm wanting to shave down the run time).
So what I was hoping to get was something that works like VB Lists, where I could look-up a value (in this case the row to output to) based on a value (the ID) without having to iterate explicitly. Would
Collection be the best way (as suggested in comments to the original question on Stack Overflow?
Failing any such thing existing in native VBA, would it be faster for me to maintain
PM (the list of previously output IDs) as a 2D array, holding IDs & row #s, and iterate through that rather than the actual rows?