excel - Sending a range to a function -
enter code herei'm having problem sending range function, seems it's sending empty range though know not.
this phone call function:
dim rcellrange excel.range dim nofwords integer dim myval string findwordsresult = findwords(rcellrange, nofwords, myval) where rcellrange specific cell, let's $a$1, nofwords integer, , myval string words for.
this function:
function findwords(celltosearch range, nofwords integer, paramarray words() variant) long dim counter long dim arr arr = split(celltosearch) dim word, element if ubound(arr) > 0 each word in words each element in arr if word = element counter = counter + 1 next next else ' cell search empty counter = 0 end if if counter = nofwords findwords = 1 else findwords = 0 end if end function it returns findwords = 0 though know should 1. have checked incoming parameters , nofwords , myval transferred correctly, rcellrange seems empty.
where problem?
edit: maybe should paste finish code instead of parts of it. know there's lot of ugly solutions, i'm no expert so... here finish code:
sub set_hyper() ' object variables dim wks excel.worksheet dim rcell excel.range, testrange excel.range, rcellrange excel.range dim ffirst string, splitsearch string, myval string dim nofwords integer, findwordsresult integer, oneword integer dim long ' sätt det inmatade ordet som sökord myval = activesheet.range("d9") set testrange = activesheet.range("d9") ' ränka antalet inskrivna ord och dela upp söksträngen flera ord nofwords = countwords(testrange) if nofwords > 1 splitsearch = split(myval)(0) else splitsearch = myval end if application.screenupdating = false application.displayalerts = false ' rensa resultatlistan från förra sökningen application.volatile (false) worksheets("start").range("d19:h99").clear ' sätt vit bakgrund på sökresultatet range("d19:h99").select selection.interior .pattern = xlsolid .patterncolorindex = xlautomatic .themecolor = xlthemecolordark1 .tintandshade = 0 .patterntintandshade = 0 end = 19 ' begin looping: each wks in activeworkbook.worksheets if wks.name <> "start" wks.range("a:e") set rcell = .find(splitsearch, , , xlpart, xlbycolumns, xlnext, false) ' if found maintain going if not rcell nil ' store first address ffirst = rcell.address set rcellrange = range(rcell.address) if nofwords > 1 findwordsresult = findwords(rcellrange, nofwords, myval) else end if ' ta reda på vilken kolumn resultetet finns och visa resultatet if findwordsresult = 1 or nofwords = 1 if rcell.column() = 1 ' link each cell occurence of {myval} rcell.hyperlinks.add cells(i, 4), "", "'" & wks.name & "'!" & rcell.address, texttodisplay:=rcell.value rcell.offset(0, 1).copy destination:=cells(i, 5) rcell.offset(0, 2).copy destination:=cells(i, 6) rcell.offset(0, 3).copy destination:=cells(i, 7) rcell.offset(0, 4).copy destination:=cells(i, 8) set rcell = .findnext(rcell) = + 1 'increment our counter end if if rcell.column() = 2 ' link each cell occurence of {myval} rcell.hyperlinks.add cells(i, 4), "", "'" & wks.name & "'!" & rcell.address, texttodisplay:=rcell.offset(0, -1).value rcell.copy destination:=cells(i, 5) rcell.offset(0, 1).copy destination:=cells(i, 6) rcell.offset(0, 2).copy destination:=cells(i, 7) rcell.offset(0, 3).copy destination:=cells(i, 8) set rcell = .findnext(rcell) = + 1 'increment our counter end if if rcell.column() = 3 ' link each cell occurence of {myval} rcell.hyperlinks.add cells(i, 4), "", "'" & wks.name & "'!" & rcell.address, texttodisplay:=rcell.offset(0, -2).value rcell.offset(0, -1).copy destination:=cells(i, 5) rcell.copy destination:=cells(i, 6) rcell.offset(0, 1).copy destination:=cells(i, 7) rcell.offset(0, 2).copy destination:=cells(i, 8) set rcell = .findnext(rcell) = + 1 'increment our counter end if if rcell.column() = 4 ' link each cell occurence of {myval} rcell.hyperlinks.add cells(i, 4), "", "'" & wks.name & "'!" & rcell.address, texttodisplay:=rcell.offset(0, -3).value rcell.offset(0, -2).copy destination:=cells(i, 5) rcell.offset(0, -1).copy destination:=cells(i, 6) rcell.copy destination:=cells(i, 7) rcell.offset(0, 1).copy destination:=cells(i, 8) set rcell = .findnext(rcell) = + 1 'increment our counter end if if rcell.column() = 5 ' link each cell occurence of {myval} rcell.hyperlinks.add cells(i, 4), "", "'" & wks.name & "'!" & rcell.address, texttodisplay:=rcell.offset(0, -4).value rcell.offset(0, -3).copy destination:=cells(i, 5) rcell.offset(0, -2).copy destination:=cells(i, 6) rcell.offset(0, -1).copy destination:=cells(i, 7) rcell.copy destination:=cells(i, 8) set rcell = .findnext(rcell) = + 1 'increment our counter end if ' test att skapa vit bakgrund selection.interior .pattern = xlsolid .patterncolorindex = xlautomatic .themecolor = xlthemecolordark1 .tintandshade = 0 .patterntintandshade = 0 end loop while not rcell nil , rcell.address <> ffirst else end if end if end end if next wks ' explicitly clear memory set rcell = nil ' if no matches found, allow user know if = 18 msgbox "the value {" & myval & "} not found on sheet", 64, "no matches" cells(1, 1).value = "" end if ' reset application settings application.screenupdating = true application.displayalerts = true end sub here countwords function:
function countwords(rrange range) long dim rcell range dim count long each rcell in rrange lcount = lcount + len(trim(rcell)) - len(replace(trim(rcell), " ", "")) + 1 next rcell countwords = lcount end function
try seems works me.
option explicit function findwords(celltosearch range, paramarray words() variant) long dim counter long dim arr variant if not isempty(celltosearch) arr = split(celltosearch) else findwords = 0 exit function end if dim word variant each word in words if not iserror(application.match(word, arr, 0)) counter = counter + 1 end if next findwords = counter end function result in worksheet: 1-word search
2-word search
result in vba:
sub test() dim long dim myval myval = array("foo", "bar") = findwords(range("a1"), myval(0), myval(1)) 'i = findwords(range("a1"), "foo", "bar") debug.print '~~> returns 2 both line code above end sub remember when utilize paramarray, need specify each element want pass in array. if different want update question. hth
excel vba excel-vba
No comments:
Post a Comment