whitehawk81
Board Regular
- Joined
- Sep 4, 2016
- Messages
- 66
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:
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:
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