Question

enter code here我在向一个函数发送一个范围时遇到了麻烦，看起来它发送的是一个空范围，虽然我知道它不是。

这是我调用函数的地方：

Dim rCellRange As Excel.Range
Dim nOfWords As Integer
Dim MyVal As String

findWordsResult = FindWords(rCellRange, nOfWords, MyVal)

其中rCellRange是一个特定的单元格，假设$ A $ 1，nOfWords是一个整数，MyVal是包含要查找的单词的字符串。

这是功能：

Function FindWords(cellToSearch As Range, nOfWords As Integer, ParamArray words() As Variant) As Long

Dim counter As Long
Dim arr
arr = Split(cellToSearch)

Dim word, element

If UBound(arr) > 0 Then
    For Each word In words
        For Each element In arr
            If word = element Then counter = counter + 1
        Next
    Next
Else
    ' cell to search is empty
    counter = 0
End If

If counter = nOfWords Then
    FindWords = 1
Else
    FindWords = 0
End If

End Function

它总是返回FindWords = 0，即使我知道它应该是1.我检查了传入的参数，nOfWords和MyVal被正确传输，但rCellRange似乎是空的。

问题出在哪里？

修改也许我应该粘贴完整的代码而不是它的一部分。我知道有很多难看的解决方案，但我不是专家所以......这是完整的代码：

  Sub Set_Hyper()

 '   Object variables
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range, testRange As Excel.Range, rCellRange As Excel.Range
Dim fFirst As String, splitSearch As String, MyVal As String
Dim nOfWords As Integer, findWordsResult As Integer, oneWord As Integer
Dim i As 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 i flera ord
nOfWords = COUNTWORDS(testRange)
If nOfWords > 1 Then
    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
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

i = 19
 '       Begin looping:
For Each wks In ActiveWorkbook.Worksheets
     If wks.Name <> "Start" Then

        With wks.Range("A:E")

            Set rCell = .Find(splitSearch, , , xlPart, xlByColumns, xlNext, False)
         '           If something is found keep going
            If Not rCell Is Nothing Then
             '               Store the first address
                fFirst = rCell.Address
                Set rCellRange = Range(rCell.Address)

                If nOfWords > 1 Then
                findWordsResult = FindWords(rCellRange, nOfWords, MyVal)
                Else
                End If

                ' Ta reda på i vilken kolumn resultetet finns i och visa resultatet
                If findWordsResult = 1 Or nOfWords = 1 Then

                Do

                    If rCell.Column() = 1 Then
                    ' Link to each cell with an 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)
                    i = i + 1 'Increment our counter

                    End If

                    If rCell.Column() = 2 Then
                    ' Link to each cell with an 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)
                    i = i + 1 'Increment our counter

                    End If

                    If rCell.Column() = 3 Then
                    ' Link to each cell with an 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)
                    i = i + 1 'Increment our counter

                    End If

                    If rCell.Column() = 4 Then
                    ' Link to each cell with an 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)
                    i = i + 1 'Increment our counter

                    End If

                    If rCell.Column() = 5 Then
                    ' Link to each cell with an 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)
                    i = i + 1 'Increment our counter

                    End If

                    ' Test att skapa vit bakgrund
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorDark1
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                    End With

                Loop While Not rCell Is Nothing And rCell.Address <> fFirst

                Else

                End If
            End If
        End With
     End If
Next wks
 '   Explicitly clear memory
Set rCell = Nothing
 '   If no matches were found, let the user know
If i = 18 Then
    MsgBox "The value {" & MyVal & "} was not found on any sheet", 64, "No Matches"
    Cells(1, 1).Value = ""
End If
 '   Reset application settings
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

这是COUNTWORDS功能：

Function COUNTWORDS(rRange As Range) As Long

Dim rCell As Range
Dim Count As Long

For Each rCell In rRange

   lCount = lCount + Len(Trim(rCell)) - Len(Replace(Trim(rCell), " ", "")) + 1

Next rCell

COUNTWORDS = lCount

结束功能

Answer 1

尝试这个似乎对我有用。

Option Explicit
Function FindWords(cellToSearch As Range, ParamArray words() As Variant) As Long
    Dim counter As Long
    Dim arr As Variant

    If Not IsEmpty(cellToSearch) Then
        arr = Split(cellToSearch)
    Else
        FindWords = 0
        Exit Function
    End If

    Dim word As Variant
    For Each word In words
        If Not IsError(Application.Match(word, arr, 0)) Then
            counter = counter + 1
        End If
    Next
    FindWords = counter
End Function

工作表中的结果：
单字搜索

enter image description here

2字搜索

enter image description here

VBA中的结果：

Sub test()
    Dim i As Long
    Dim myval
    myval = Array("Foo", "bar")

    i = FindWords(Range("A1"), myval(0), myval(1))
    'i = FindWords(Range("A1"), "Foo", "bar")
    Debug.Print i '~~> this returns 2 for both line code above
End Sub

请记住，当您使用 ParamArray 时，您需要指定要在数组中传递的每个元素。
如果这与您想要的有些不同，请更新您的问题。 HTH

Answer 2

您的功能正常但

调用时，您没有向函数提供任何有效范围。
可能是您的搜索案例与Excel中的实际情况不同

请参阅我的修改：

Public Sub test()
Dim rCellRange As Excel.Range
Dim nOfWords As Integer
Dim MyVal As String

'BEFORE RUNNING THIS, please put "The Big Blue Fox Flew over the cuccoo nest" in to the cell A1
Set rCellRange = ThisWorkbook.Worksheets(1).Range("A1")
nOfWords = 1
MyVal = "Fox"
findWordsResult = FindWords(rCellRange, nOfWords, MyVal)

MsgBox findWordsResult

End Sub

Function FindWords(cellToSearch As Range, nOfWords As Integer, ParamArray words() As Variant) As Long

    Dim counter As Long
    Dim arr
    arr = Split(cellToSearch)

    Dim word, element

    If UBound(arr) > 0 Then
        For Each word In words
            For Each element In arr
                'If you want to make this case insensitive, use: If UCase(word) = UCase(element) Then counter = counter + 1
                If word = element Then counter = counter + 1
            Next
        Next
    Else
        ' cell to search is empty
        counter = 0
    End If

    If counter = nOfWords Then
        FindWords = 1
    Else
        FindWords = 0
    End If

    End Function

将范围发送到函数

2 个答案: