Redim doesn't work after script was run successfully

[whitehawk81]

Hi there,
I managed to run the script only once without error. But now I get a value error and it seems that the Redim is not resizing the arrays.
Originally I used Redim Preserve but after the error I also tried to resize them at the initialization, but neither of them seems to work now.
Here is my code:

Function Kwrd(strText As Range) As VariantDim c As Range
Dim i As Long
Dim sID As Long
Dim sCount As Long
Dim solArr() As Long
Dim countArr() As Long
Dim Words As Range
Dim myRange As Range
Set Words = Range("kw")
Set myRange = Range("kwmap")


On Error GoTo Hell


'ReDim solArr(1 To UBound(solArr))
'ReDim countArr(1 To UBound(countArr))
    
For Each c In Words
    If InStr(1, strText, c, 1) > 0 Then
    
    '----------------found keywords are mapped and replaced with solution ID
    'ReDim Preserve solArr(i)
    solArr(i) = Application.WorksheetFunction.VLookup(c, myRange, 3, False)


    i = i + 1
   
    End If
Next c


For i = LBound(solArr) To UBound(solArr)
If solArr(i) <> 0 Then
'----------------same values are counted
    For sID = 1 To 10
    'ReDim Preserve countArr(sID)
        countArr(sID) = CountArray(solArr, sID)
    Next sID


'----------------result is set to ID with max value
    Kwrd = FindMax(countArr)


End If
Next i


Hell:
Kwrd = "No keyword found."


End Function
Private Function CountArray(Arr() As Long, ToFind As Long) As Long
Dim i As Long
    For i = LBound(Arr) To UBound(Arr)
        If Arr(i) = ToFind Then
            CountArray = CountArray + 1
        End If
    Next
End Function
Private Function FindMax(Arr() As Long) As Long
Dim myMax As Long
Dim i As Long
  
  For i = LBound(Arr) To UBound(Arr)
    If Arr(i) > myMax Then
      myMax = Arr(i)
      FindMax = i
    End If
  Next i
End Function

 

[whitehawk81]

I uploaded it here.

 

[Norie]

Try this.

Function KwSearch(strText As Range) As Variant
Dim c As Range
Dim i As Long
Dim sID As Long
Dim sCount As Long
Dim solArr() As Variant
Dim countArr() As Long
Dim Words As Range
Dim myRange As Range

Dim Res As Variant

    Set Words = Range("kw")
    Set myRange = Range("KwTable")

    For Each c In Words
        If InStr(1, strText, c, 1) = 0 Then
            Res = 0
        Else
            '----------------found keywords are mapped and replaced with solution ID
            ReDim Preserve solArr(i)

            Res = Application.VLookup(c, myRange, 3, False)

            If Not IsError(Res) Then
                solArr(i) = Res
            Else
                solArr(i) = 0
            End If

            i = i + 1

        End If
    Next c
    
    If i = 0 Then
        KwSearch = "Not Found"
        Exit Function
    End If
    
    For i = LBound(solArr) To UBound(solArr)
        If solArr(i) <> 0 Then
            '----------------same values are counted
            For sID = 1 To 10
                ReDim Preserve countArr(sID)
                countArr(sID) = CountArray(solArr, sID)
            Next sID
            '----------------result is set to ID with max value
            KwSearch = FindMax(countArr)
        End If
    Next i

End Function

Private Function CountArray(Arr() As Variant, ToFind As Long) As Long
Dim i As Long
    For i = LBound(Arr) To UBound(Arr)
        If Arr(i) = ToFind Then
            CountArray = CountArray + 1
        End If
    Next
End Function

Private Function FindMax(Arr() As Long) As Long
Dim myMax As Long
Dim i As Long

    For i = LBound(Arr) To UBound(Arr)
        If Arr(i) > myMax Then
            myMax = Arr(i)
            FindMax = i
        End If
    Next i
End Function

 

[whitehawk81]

Thank you very much! It works like a charm now.