在宏中引用用户函数的最佳方法 [英] Best methods to reference a user function in a macro

问题描述

下午，

我目前已保存此用户功能：

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.

有人可以提供任何建议吗？我想知道如果我可以以某种方式将User Function嵌入到宏中，或者将它集中存储在一起。

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.

谢谢。

请参阅完整的宏以及用户功能在最后：

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

推荐答案

通过评论：
尝试在选择案例之前添加一个tempValue

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

这篇关于在宏中引用用户函数的最佳方法的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！