Please Improve My Slow User Defined Function, Excel 2010 VBA

[ceddins]

Good morning, all.

I'm somewhat new to VBA, so I need your expert help with something. I have a UDF that looks for a Unique ID (quote number) in a range/array and returns all the corresponding 3-letter codes into a single cell. I only want each 3-letter code to be returned once even though there will be many occurrences of each.

I think the slowest part of the code is in the beginning section that I've marked with a comment.

Thank you in advance for your help!

Here's the code:

Option Base 1
Option Explicit

Public Function MHC(QuoteNumber As Range)

Dim QuoteNumStart As Integer
Dim QuoteNumCount As Integer
Dim MrkPrFxRng As Range
Dim QuoteNumTrim()
Dim x
Dim xCounter
xCounter = 0
'Fill QuoteNumTrim with values in the "QuoteNum_ColRef" range
'this is the section of code that could use the most improvement
For x = 1 To ThisWorkbook.Worksheets("MRDW group pickup").Range("QuoteNum_ColRef").Count Step 1
xCounter = xCounter + 1
ReDim Preserve QuoteNumTrim(xCounter)
QuoteNumTrim(x) = Trim(ThisWorkbook.Worksheets("MRDW group pickup").Range("QuoteNum_ColRef")(x, 1))
Next

'Find the first occurrence of the quote number
QuoteNumStart = Application.WorksheetFunction.Match(QuoteNumber, QuoteNumTrim, 0) + 1

'Count the number of times that quote number is found and assign it to QuoteNumCount
Set x = Nothing
Set xCounter = Nothing
xCounter = 0
For x = 1 To UBound(QuoteNumTrim) Step 1
If QuoteNumTrim(x) = QuoteNumber Then
xCounter = xCounter + 1
End If
Next
QuoteNumCount = xCounter

'Find Market Prefix name column
Dim HdrVar
Dim HdrUsedCols
Dim MrkPrFxCol
HdrUsedCols = ThisWorkbook.Sheets("MRDW group pickup").UsedRange.Columns.Count
For HdrVar = 1 To HdrUsedCols Step 1
If ThisWorkbook.Sheets("MRDW group pickup").Cells(1, HdrVar) = "Market Prfx Name for Report" Then
MrkPrFxCol = HdrVar
Exit For
End If
Next

'identify the range of mini hotel codes
Set MrkPrFxRng = ThisWorkbook.Sheets("MRDW group pickup").Range(ThisWorkbook.Sheets("MRDW group pickup").Cells(QuoteNumStart, MrkPrFxCol).Address, ThisWorkbook.Sheets("MRDW group pickup").Cells((QuoteNumStart + QuoteNumCount - 1), MrkPrFxCol).Address)

'fill an array with 1 of each corresponding mini hotel code
Dim MrkPrFxArray()
Dim i
Dim UniqueCounter
UniqueCounter = 0

For i = 2 To MrkPrFxRng.Count + 1 Step 1
If (i = MrkPrFxRng.Count) And (MrkPrFxRng(i - 1, 1) <> MrkPrFxRng(i, 1)) Then
UniqueCounter = UniqueCounter + 1
ReDim Preserve MrkPrFxArray(1 To UniqueCounter)
MrkPrFxArray(UniqueCounter) = Left(MrkPrFxRng(i, 1), 3)
End If
If MrkPrFxRng(i, 1) <> MrkPrFxRng(i - 1, 1) Then
UniqueCounter = UniqueCounter + 1
ReDim Preserve MrkPrFxArray(1 To UniqueCounter)
MrkPrFxArray(UniqueCounter) = Left(MrkPrFxRng(i - 1, 1), 3)
End If
Next

'create string of Mini Hotel Codes
Set i = Nothing
Dim MHCString
MHCString = ""
For i = 1 To UBound(MrkPrFxArray)
MHCString = MHCString + MrkPrFxArray(i) + ", "
If i = UBound(MrkPrFxArray) Then
MHCString = Left(MHCString, Len(MHCString) - 2)
End If
Next

MHC = MHCString

End Function

 

[SkipVought]

hi,

Several thoughts.

Place ALL declarations at the beginning of youor procedure.

Declare variables at the lowest storage requirement as necessary. Integral counters ought to be declared as Integer or Long. You do not need to initialize variables that will have direct values assigned, for instance,
declare i as Integer and MHCString as String
i is not an object, hence no Set is require and since it is directly assigned in the For...Next loop, does not need to be initialized.

    'create string of Mini Hotel Codes
    MHCString = ""
    For i = 1 To UBound(MrkPrFxArray)
        MHCString = MHCString + MrkPrFxArray(i) + ", "
        If i = UBound(MrkPrFxArray) Then
            MHCString = Left(MHCString, Len(MHCString) - 2)
        End If
    Next

rather than testing for i = UBound(MrkPrFxArray), just execute the statement immediatly after the loop

    'create string of Mini Hotel Codes
    MHCString = ""
    For i = 1 To UBound(MrkPrFxArray)
        MHCString = MHCString + MrkPrFxArray(i) + ", "
    Next
    MHCString = Left(MHCString, Len(MHCString) - 2)
[/coded]
Furthermore declare the Function an as string and then...
[code]
Public Function MHC(QuoteNumber As Range) As String
'....... stuff here


    'create string of Mini Hotel Codes
    MHC = ""
    For i = 1 To UBound(MrkPrFxArray)
        MHC = MHC + MrkPrFxArray(i) + ", "
    Next
    MHC = Left(MHC, Len(MHC) - 2)

End Function

There is some overhead in Redim Preserve. You already know the [highlight]number of elements[/highlight]
BTW, Step 1 is the default step value in For...Next, and need not be explicitly coded.

    For x = 1 To [highlight]ThisWorkbook.Worksheets("MRDW group pickup").Range("QuoteNum_ColRef").Count[/highlight] Step 1
        xCounter = xCounter + 1
        ReDim Preserve QuoteNumTrim(xCounter)
        QuoteNumTrim(x) = Trim(ThisWorkbook.Worksheets("MRDW group pickup").Range("QuoteNum_ColRef")(x, 1))
    Next

If it were me, I'd convert your Quote Number table to a Structured Table (assuming that your Excel version is 2007+), via Insert > Tables > Table. Then this becomes...

    QuoteNumStart = Application.WorksheetFunction.Match(QuoteNumber, QuoteNumTrim, 0) + 1

this

    QuoteNumStart = Application.WorksheetFunction.Match(QuoteNumber, [tQuotes[QuoteNumTrim]], 0) + 1

assuming that you name the table tQuotes and that QuoteNumTrim is the heading value in that table.

But now I'm looking at this code less in detail and more as what is it doing, and i wonder if this whole thing might be able to be done without code. Could you explain the process, without referring to code. In other words, could you explain WHAT it is you're doing, rather than HOW you think it ought to be done.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[Andrzejek]

How about:

Dim intMyCount As integer

intMyCount = ThisWorkbook.Worksheets("MRDW group pickup").Range("QuoteNum_ColRef").Count

ReDim QuoteNumTrim(intMyCount)

For x = 1 To intMyCount [green]'Step 1 that's Default[/green]
  QuoteNumTrim(x) = Trim(ThisWorkbook.Worksheets("MRDW group pickup").Range("QuoteNum_ColRef")(x, 1))
Next

BTW, Your Function MHC returns Variant
These below are all Variants as well:
[tt]Dim QuoteNumTrim()
Dim x
Dim xCounter

Dim HdrVar
Dim HdrUsedCols
Dim MrkPrFxCol

Dim MrkPrFxArray()
Dim i
Dim UniqueCounter

Dim MHCString
[/tt]


Have fun.

---- Andy

 

[ceddins]

Hi SkipVought. Thank you for taking a look at this for me.

Here's what I'm trying to do:

I have a table of information about groups (address, contact, group name, etc) on a data tab. It is imported from an outside datasource. On another data tab is a lot of data (20k+ rows) about groups' room blocks (room blocks at a convention resort) like how many rooms they have contracted per night and the rate and the mini hotel code. This data is pasted in from a different data source. Groups are identified by a unique quote number. For each group, there could be an indefinite number of 3 digit mini-hotel codes and each of these codes could appear hundreds of times because the data has a different record for each day of the room block and each room type. We set up a separate tab for each group where we have a nicely formatted summary of their info and block. Using the quote number in cell C1 of each tab, all the formulas on this individual group tab do VLookups to find this information. I have a cell on this individual group tab that needs to return all the different mini-hotel codes (once each) in this form: "ABC, DEF, GHI, JKL"

The mini-hotel code data on the data tab has the 3 letter code AND the description of the code in each cell, so I just want to extract the first 3 letters of each cell. "ABC" instead of "ABC - AB Corporation".
The quote numbers on this data tab, for some reason that gives me a headache, come from this external data source with a ton of spaces after the quote number. So, I can't just do a straight vlookup of "M-XYZ". The data comes out like "M-XYZ ". I cannot change how the data comes out of the data source.
I don't want to add another step for the user since there's already a lot of manual labor involved.

Does that help clarify for you?

 

[SkipVought]

So if this function is going to be used on 10s of thousands of rows, it might behove you to pre-process the lookup table(s) into global array(s), for instance in the Workbook_Open event. Then your function need not refer to a sheet and load an array. That would already be done. Your function would just loop thru the global array(s), assemble your string and return the value.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[SkipVought]

But I'd try accessing the Structured table, You can use the COUNTIF or COUNTIFS function to count the occurrences of one or more criteria without looping. THAT would save processing time.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[ceddins]

SkipVaught,

I have a dynamic named range "Quote_Num" that creates an array of each quote number, trimmed, in the dataset, but when I try to refer to this array in my code like this....

QuoteNumStart = Application.WorksheetFunction.Match(QuoteNumber, ThisWorkbook.Sheets("MRDW group pickup").Range("Quote_Num"), 0) + 1

I get either a 'type mismatch' error or 'unable to set match property of worksheetfunction class' (not sure of the exact wording on the error). If I could get that line to work, I could probably get rid of the first loop that fills the QuoteNumTrim array.

Any suggestions on how to get that to work?

 

[SkipVought]

You also refer to copy 'n' paste (CNP) to assemble some data. I notice that you post in the DB2 forum.

Be aware that you can use MS Query to access external data sources like DB2, Oracle, MS Access, Excel files and Excel sheets (tables) within your workbook, and TEXT file imports, that can be used to avoid many CNP operations. I am a data bully, pushing data around in my application. CNP is generally wimpy. ;-)

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[bubba100]

Every time I have to deal with data from an outside source in Excel I first run the following.

'Remove pesky spaces

Dim rCell As Range
Dim rText As Range
Set rText = Cells.SpecialCells( _
xlCellTypeConstants, _
xlTextValues)
For Each rCell In rText
rCell.Value = Trim(rCell)
If Trim(rCell.Value) = "" Then
rCell.ClearContents
End If
Next
Set rText = Nothing
Set rCell = Nothing

 

[SkipVought]

You declare QuoteNumber as RANGE!!!

It sould be EITHER a STRING or an INTEGER. Probably a string would be better. That code WORKS if the lookup variable is properly declared consistent with the data tyep in the table.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[ceddins]

Thank you all for your suggestions. I will try them out (probably this evening) and let you know what happens.

 

[ceddins]

Good evening, all.

Just an update to let you know that I took most of your ideas and was able to condense my code and make it more efficient and faster. The function runs in a couple seconds (and I'm connected through VPN, so I'm sure it will be unnoticeable back at the office). Thank you all very much. (See the final code down at the bottom)

SkipVaught: I liked the idea of using a global variable so that the QuoteNumTrim array is populated once (which would happen in my change event on the tab where the data gets pasted) and then is passed to this function. But, I've never used a global variable, so I wasn't able to get it to work correctly. Plus, I didn't know whether I could declare a global variable, define it in a private sub worksheet change and then have the value pass to this function. (If you could explain to me and/or show me how that would work, I would be honored).

Thanks, again!

Here's the final code:

Option Base 1
Option Explicit

Public Function MHC(QuoteNumber As Range) As String

Dim QuoteNumStart As Integer
Dim QuoteNumCount As Integer
Dim MrkPrFxRng As Range
Dim QuoteNumTrim()
Dim x As Integer
Dim xCounter As Integer
Dim HdrVar As Integer
Dim HdrUsedCols As Integer
Dim MrkPrFxCol As Integer
Dim MrkPrFxArray()
Dim i As Integer
Dim UniqueCounter As Integer
Dim MHCString As String
Dim DataTab As Worksheet

Set DataTab = ThisWorkbook.Sheets("MRDW group pickup")

'Fill QuoteNumTrim with values in the "QuoteNum_ColRef" range
ReDim QuoteNumTrim(DataTab.Range("QuoteNum_ColRef").Count)
For x = 1 To DataTab.Range("QuoteNum_ColRef").Count
QuoteNumTrim(x) = Trim(DataTab.Range("QuoteNum_ColRef")(x, 1))
Next

'Find the first occurrence of the quote number
QuoteNumStart = Application.WorksheetFunction.Match(QuoteNumber, QuoteNumTrim, 0) + 1

'Count the number of times that quote number is found and assign it to QuoteNumCount
x = 0
xCounter = 0
For x = 1 To UBound(QuoteNumTrim)
If QuoteNumTrim(x) = QuoteNumber Then
xCounter = xCounter + 1
End If
Next
QuoteNumCount = xCounter

'Find Market Prefix name column
HdrUsedCols = DataTab.UsedRange.Columns.Count
For HdrVar = 1 To HdrUsedCols
If DataTab.Cells(1, HdrVar) = "Market Prfx Name for Report" Then
MrkPrFxCol = HdrVar
Exit For
End If
Next

'Define the range of mini hotel codes
Set MrkPrFxRng = DataTab.Range(DataTab.Cells(QuoteNumStart, MrkPrFxCol).Address, DataTab.Cells((QuoteNumStart + QuoteNumCount - 1), MrkPrFxCol).Address)

UniqueCounter = 0

'fill an array with 1 of each corresponding mini hotel code
ReDim MrkPrFxArray(1 To QuoteNumCount)
For i = 2 To MrkPrFxRng.Count + 1
If (i = MrkPrFxRng.Count) And (MrkPrFxRng(i - 1, 1) <> MrkPrFxRng(i, 1)) Then
UniqueCounter = UniqueCounter + 1
MrkPrFxArray(UniqueCounter) = Left(MrkPrFxRng(i, 1), 3)
End If
If MrkPrFxRng(i, 1) <> MrkPrFxRng(i - 1, 1) Then
UniqueCounter = UniqueCounter + 1
MrkPrFxArray(UniqueCounter) = Left(MrkPrFxRng(i - 1, 1), 3)
End If
Next
ReDim Preserve MrkPrFxArray(1 To UniqueCounter)

'create string of Mini Hotel Codes
MHC = ""
For i = 1 To UBound(MrkPrFxArray)
MHC = MHC + MrkPrFxArray(i) + ", "
Next
MHC = Left(MHC, Len(MHC) - 2)

End Function

 

[SkipVought]

Global variables are declared in a module, BEFORE any procedures.

Option Explicit
Option Base 1

Public vQuotes()

Sub ....

End Sub

A variable declared as such can be referenced in any module, sheet object, workbook object, class or userform.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]