excel - Best methods to reference a user function in a macro -
afternoon,
i have user function saved:
function alphanumericonly(strsource string) string dim integer dim strresult string = 1 len(strsource) select case asc(mid(strsource, i, 1)) case 48 57, 65 90, 97 122: 'include 32 if want include space strresult = strresult & mid(strsource, i, 1) end select next alphanumericonly = strresult end function i call user function in macros run (checking open in macro). issue i'm having when need share macro references user.
i of course copy user function , send along copy of macro, save locally , adjust macro check local copy open. seems quite long winded.
could offer suggestions? wondering if somehow embed user function in macro, or store centrally how. web searching , asking around has drawn blank on one.
thank you.
please see complete macro along user function @ 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 long dim cl range dim rng range dim mssg string dim ws worksheet dim savetodirectory string dim dateformat string dim statementname string dim organisation string dim errormessage string dim errormessagetitle string dim completemessage string dim completemessagetitle string dim userfunctionslocation string dim savelocation string dateformat = format(cstr(now), "yyyy_mm_dd_hhmmss_") errormessagetitle = "invalid date format" errormessage = "there invalid date value(s) in following cell(s). please check these cells." completemessagetitle = "statement preparation" completemessage = "statement preparation complete. file has been saved , processed part of next scheduled upload." statementname = "age_bts" organisation = "bts" ' save locations '*location of 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 formats sheet ws .cells.clearformats end 'standardises fonts ws.cells.font .name = "calibri" .size = 10 .bold = false end ws 'cleans non_printable characters data (excluding date columns) & removes "'" & "," 'trims insurer comments field ensure 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)) each cl in rng if cl.column = 39 'column gets left() truncation 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 dd/mm/yyyy union(.range("ab1:ab" & lr), .range("ac1:ac" & lr), .range("ap1:ap" & lr)).numberformat = "dd/mm/yyyy" 'formats numerical fields "0.00" union(.range("ad2:al" & lr), .range("ao2:ao" & lr)).numberformat = "0.00" 'add statement name range("a2:a" & lr).formular1c1 = statementname 'add organisation name range("d2:d" & lr).formular1c1 = organisation 'adds formula generate unique key (from declared constant) range("b2:b" & lr).formula = csformula range("b2:b" & lr) = range("b2:b" & lr).value 'auto-fit columns ws .columns.autofit end 'checks date values present in invoice_date, effective_date & spare_date set rng = union(.range("ab2:ab" & lr), .range("ac2:ac" & lr), .range("ap2:ap" & lr)) each cl in rng if not isdate(cl.value) , not isempty(cl) _ mssg = mssg & cl.address(0, 0) & space(4) next cl end 'if non-date values found display message box showing cell locations if cbool(len(mssg)) msgbox (errormessage & chr(10) & chr(10) & _ mssg & chr(10) & chr(10)), vbcritical, errormessagetitle 'otherwise display message statement preparation complete else msgbox completemessage, , completemessagetitle end if 'save location .csv savetodirectory = savelocation 'uses set dateformat , 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 string) string dim integer dim strresult string = 1 len(strsource) select case asc(mid(strsource, i, 1)) case 48 57, 65 90, 97 122: 'include 32 if want include space strresult = strresult & mid(strsource, i, 1) end select next alphanumericonly = strresult end function
working through comments: try adding tempvalue before select case
function alphanumericonly(strsource string) string dim integer dim strresult string dim tempvalue integer = 1 len(strsource) tempvalue = asc(mid(strsource, i, 1)) select case tempvalue case 48 57, 65 90, 97 122: 'include 32 if want include space strresult = strresult & mid(strsource, i, 1) end select next alphanumericonly = strresult end function 
Comments
Post a Comment