Best methods to reference a user function in a macro

Question

Afternoon,

I currently have this User Function saved:

Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

I call this User Function in some macros that I run (checking that it is open in the macro). The issue I'm having is when I need to share a macro that references this with another user.

I could of course copy the User Function and send that along with a copy of the macro, they could then save it locally and adjust the macro to check their local copy is open. But this seems quite long winded.

Could anybody offer any suggestions? I am wondering if I could somehow embed the User Function in the macro, or store it centrally some how. Some web searching and asking around has drawn a blank on this one.

Thank you.

Please see the complete macro along with the user function at the end:

Option Explicit
Public Const csFORMULA = "=concatenate(""AGSBIS"",IF(I2=0,"""",CONCATENATE(UPPER(AlphaNumericOnly(LEFT(I2,3))),UPPER(AlphaNumericOnly(RIGHT(I2,3))))),IF(O2=0,"""",UPPER(AlphaNumericOnly(SUBSTITUTE(O2,""0"","""")))),IF(R2=0,"""",UPPER(AlphaNumericOnly(SUBSTITUTE(R2,""0"","""")))),IF(W2=0,"""",UPPER(AlphaNumericOnly(SUBSTITUTE(W2,""0"","""")))),IF(AC2=0,"""",AlphaNumericOnly(SUBSTITUTE(AC2,""0"",""""))),IF(AD2=0,"""",SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(AD2,""-"",""X""),""."",""Y""),""0"",""Z"")),IF(AF2=0,"""",SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(AF2,""-"",""X""),""."",""Y""),""0"",""Z"")),IF(AH2=0,"""",SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(AH2,""-"",""X""),""."",""Y""),""0"",""Z"")))"

Sub AgeasBIS()

    Dim lr                      As Long
    Dim cl                      As Range
    Dim Rng                     As Range
    Dim mssg                    As String
    Dim WS                      As Worksheet
    Dim SaveToDirectory         As String
    Dim DateFormat              As String
    Dim StatementName           As String
    Dim Organisation            As String
    Dim ErrorMessage            As String
    Dim ErrorMessageTitle       As String
    Dim CompleteMessage         As String
    Dim CompleteMessageTitle    As String
    Dim UserFunctionsLocation   As String
    Dim SaveLocation            As String

    DateFormat = Format(CStr(Now), "yyyy_mm_dd_hhmmss_")

    ErrorMessageTitle = "Invalid Date Format"
    ErrorMessage = "There are invalid date value(s) in the following cell(s). Please check these cells."

    CompleteMessageTitle = "Statement Preparation"
    CompleteMessage = "Statement preparation is complete. Your file has been saved and will be processed as part of the next scheduled upload."

    StatementName = "age_bts"
    Organisation = "BTS"

    ' save locations
    '*location of the old user function* UserFunctionsLocation = "C:\Users\user.name\AppData\Roaming\Microsoft\AddIns\UserFunctions.xla"
    SaveLocation = "S:\MI\gre_cac\statement_feeds\waiting_to_upload\"


    Set WS = ActiveSheet

        Application.ScreenUpdating = False

    Workbooks.Open Filename:=UserFunctionsLocation

'clears any formats from the sheet
    With WS
        .Cells.ClearFormats
    End With

'standardises all fonts
    With WS.Cells.Font
        .Name = "Calibri"
        .Size = 10
        .Bold = False
    End With


    With WS
'cleans all non_printable characters from the data (excluding date columns) & removes "'" & ","
'trims the insurer comments field to ensure it is a maximum of 500 characters

        lr = .Range("I" & Rows.Count).End(xlUp).Row

        Set Rng = Union(.Range("C2:AA" & lr), .Range("AD2:AO" & lr), .Range("AM2:AM" & lr))
        For Each cl In Rng
            If cl.Column = 39 Then 'column AM gets Left() truncation as well
                cl = Left(WorksheetFunction.Trim(WorksheetFunction.Clean(cl.Value)), 500)
                cl = WorksheetFunction.Substitute(cl.Value, "'", "")
                cl = WorksheetFunction.Substitute(cl.Value, ",", "")
            Else
                cl = WorksheetFunction.Trim(WorksheetFunction.Clean(cl.Value))
                cl = WorksheetFunction.Substitute(cl.Value, "'", "")
                cl = WorksheetFunction.Substitute(cl.Value, ",", "")
            End If
            Next cl

'format invoice_date, effective_date & spare_date to dd/mm/yyyy
            Union(.Range("AB1:AB" & lr), .Range("AC1:AC" & lr), .Range("AP1:AP" & lr)).NumberFormat = "dd/mm/yyyy"

'formats all numerical fields to "0.00"
            Union(.Range("AD2:AL" & lr), .Range("AO2:AO" & lr)).NumberFormat = "0.00"

'add the statement name
            Range("A2:A" & lr).FormulaR1C1 = StatementName

'add the organisation name
            Range("D2:D" & lr).FormulaR1C1 = Organisation

'adds the formula to generate the unique key (from the declared constant)

            Range("B2:B" & lr).Formula = csFORMULA
            Range("B2:B" & lr) = Range("B2:B" & lr).Value

'auto-fit all columns
    With WS
        .Columns.AutoFit
    End With

'checks that only date values as present in the invoice_date, effective_date & spare_date
            Set Rng = Union(.Range("AB2:AB" & lr), .Range("AC2:AC" & lr), .Range("AP2:AP" & lr))
            For Each cl In Rng
                If Not IsDate(cl.Value) And Not IsEmpty(cl) Then _
                mssg = mssg & cl.Address(0, 0) & Space(4)
                Next cl

            End With

'If non-date values are found display a message box showing the cell locations
            If CBool(Len(mssg)) Then
                MsgBox (ErrorMessage & Chr(10) & Chr(10) & _
                mssg & Chr(10) & Chr(10)), vbCritical, ErrorMessageTitle

'Otherwise display a message that the statement preparation is complete
            Else
                MsgBox CompleteMessage, , CompleteMessageTitle
            End If


'save location for the .csv
SaveToDirectory = SaveLocation

'uses the set dateformat and save lovation

        WS.SaveAs SaveToDirectory & DateFormat & StatementName, xlCSV


      Set Rng = Nothing
            Set WS = Nothing
            Application.ScreenUpdating = True

         ActiveWorkbook.Close SaveChanges:=False


        End Sub

Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

If you could include any errors you are receiving in your post, and also some of the macro that calls this function. At least the part that calls it, and any variables being passed, where they are declared and assigned values. — peege, Dec 16 '14 at 13:00
side note: you can use 'Replace(textValue, ",", "")' instead of worksheetfunctions — peege, Dec 16 '14 at 13:08

peege · Accepted Answer · 2014-12-16T13:27:55.380

1

Working through the comments: Try adding a tempValue before the Select Case

Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String
    Dim tempValue As Integer

    For i = 1 To Len(strSource)
        tempValue = Asc(Mid(strSource, i, 1))
        Select Case tempValue
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

edited Dec 16 '14 at 13:27

answered Dec 16 '14 at 12:23

peege

2,467
1
10
24

Unfortunately when I try this the corresponding output from the macro contains an error in the cell. When the data is run with the User Function stored separately it runs fine. – chris1982 Dec 16 '14 at 12:57
Apologies, the cells that should contain data are just showing as #error. I'll post the full macro with your suggested addition above. Thanks for looking. – chris1982 Dec 16 '14 at 13:02
@chris1982 I modified this to assign a tempValue then use the select case. although I'd rather see the results of a step through debugging. – peege Dec 16 '14 at 13:20
Perfect. Worked extremely well. Thank you so much. – chris1982 Dec 16 '14 at 13:27

score 0 · Answer 2 · answered Dec 20 '14 at 09:53

Using Regular Expressions offers a shorter more efficient solution then examining each character:

Function AlphaNumericOnly(strIn) As String
    Dim objRegex As Object
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .Global = True
        .ignorecase = True
        .Pattern = "[^\w]+"
        AlphaNumericOnly = .Replace(strIn, vbNullString)
    End With
End Function

Best methods to reference a user function in a macro

2 Answers2

Linked