Array search

[pwwato]

Hi Everyone thanks for taking the time to look at this.

I'm trying to create a function that will check an 2darray containing worksheet data simply called arr at moment, the data consists off 90 rows x 7 columns at present but the rows can and will increase over time.
I'm checking for a reference number located in first column which could appear multiple times and I want the required reference,s full rows added to a temp array. the object for this is to act as a filter for a combo box in a userform. I have tried many different ways and believe I am close to getting it right but it seems to fail copying the found rows to the temp array. I would supply the code but don't seem to be able to copy and paste it into the post like I used to for some reason.
can any one help with a standalone function that works that I can tweak to suit my needs.

Many thanks

 

[pwwato]

just changed to a different browser and managed to paste the code .

Public Function filter2dArray(sourcearr As Variant, matchStr As String) As Variant
Dim matchArrIndex As Variant, splitArr As Variant
Dim i As Integer, outerindex As Integer, innerIndex As Integer, tempArrayIndex As Integer, CurrIndex As Integer, stringLength As Integer, matchType As Integer
Dim increaseIndex As Boolean
Dim actualStr As String
Dim temparray() As Variant

splitArr = Split(matchStr, "*")
On Error GoTo errorHandler
If UBound(splitArr) = 0 Then
matchType = 0 'Exact Match
actualStr = matchStr
ElseIf UBound(splitArr) = 1 And splitArr(1) = "" Then
matchType = 1 'Starts With
actualStr = splitArr(0)
ElseIf UBound(splitArr) = 1 And splitArr(0) = "" Then
matchType = 2 'ends With
actualStr = splitArr(1)
ElseIf UBound(splitArr) = 2 And splitArr(0) = "" And splitArr(2) = "" Then
matchType = 3 'contains
actualStr = splitArr(1)
Else
MsgBox "Incorrect match provided"
Exit Function
End If
'start index
i = LBound(sourcearr, 1)
'resize array for matched values
ReDim matchArrIndex(LBound(sourcearr, 1) To UBound(sourcearr, 1)) As Variant
'outer loop
For outerindex = LBound(sourcearr, 1) To UBound(sourcearr, 1)
'inner loop
For innerIndex = LBound(sourcearr, 2) To UBound(sourcearr, 2)
'if string matches with array elements
If (matchType = 0 And sourcearr(outerindex, innerIndex) = actualStr) Or _
(matchType = 1 And Left(sourcearr(outerindex, innerIndex), Len(actualStr)) = actualStr) Or _
(matchType = 2 And Right(sourcearr(outerindex, innerIndex), Len(actualStr)) = actualStr) Or _
(matchType = 3 And InStr(sourcearr(outerindex, innerIndex), actualStr) <> 0) Then
increaseIndex = True
matchArrIndex(i) = outerindex
End If
Next
If increaseIndex Then
tempArrayIndex = tempArrayIndex + 1
increaseIndex = False
i = i + 1
End If
Next
'if no matches found, exit the function
If tempArrayIndex = 0 Then
Exit Function
End If
If LBound(sourcearr, 1) = 0 Then
tempArrayIndex = tempArrayIndex - 1

This is where it seems to fail i think
End If
'resize temp array
ReDim Preserve temparray(LBound(sourcearr, 1) To tempArrayIndex, LBound(sourcearr, 2) To UBound(sourcearr, 2)) As Variant
'i = i - 1
CurrIndex = LBound(sourcearr, 1)
Dim j As Integer
j = LBound(matchArrIndex)
'store values in temp array
For i = CurrIndex To UBound(temparray)
For innerIndex = LBound(temparray, 1) To UBound(temparray, 2)
temparray(i, innerIndex) = sourcearr(matchArrIndex(j), innerIndex)
Next
j = j + 1
Next

'Application.ScreenUpdating = True
'Application.Workbooks("yesdatav2.xlsm").Sheets(Sheet14).Select
'Sheets(Sheet14).Range("A1").Resize(UBound(temparray) + 1, UBound(temparray, 4) + 1) = temparray
filter2dArray = temparray

Exit Function
errorHandler:
MsgBox "Error :" & Err.Description
End Function

It completes ok but theres nothing in temparrayor filter2darray if i add the code to copy to sheet i get error type mismatch?

 

[jolivanes]

Still not the right browser. Still needs code tags.

 

[pwwato]

Code tags? what are these tried edge and firefox? latter post done on firefox.

 

[jolivanes]

I was just kidding on the browser. Google for "What are code tags?" I am sure there will be a better explanation than I can give you.

 

[pwwato]

Public Function filter2dArray(sourcearr As Variant, matchStr As String) As Variant
Dim matchArrIndex As Variant, splitArr As Variant
Dim  i As Integer, outerindex As Integer, innerIndex As Integer,   tempArrayIndex As Integer, CurrIndex As Integer, stringLength As   Integer, matchType As Integer
Dim increaseIndex As Boolean
Dim actualStr As String
Dim temparray() As Variant

splitArr = Split(matchStr, "*")
On Error GoTo errorHandler
If UBound(splitArr) = 0 Then
matchType = 0 'Exact Match
actualStr = matchStr
ElseIf UBound(splitArr) = 1 And splitArr(1) = "" Then
matchType = 1 'Starts With
actualStr = splitArr(0)
ElseIf UBound(splitArr) = 1 And splitArr(0) = "" Then
matchType = 2 'ends With
actualStr = splitArr(1)
ElseIf UBound(splitArr) = 2 And splitArr(0) = "" And splitArr(2) = "" Then
matchType = 3 'contains
actualStr = splitArr(1)
Else
MsgBox "Incorrect match provided"
Exit Function
End If
'start index
i = LBound(sourcearr, 1)
'resize array for matched values
ReDim matchArrIndex(LBound(sourcearr, 1) To UBound(sourcearr, 1)) As Variant
'outer loop
For outerindex = LBound(sourcearr, 1) To UBound(sourcearr, 1)
'inner loop
For innerIndex = LBound(sourcearr, 2) To UBound(sourcearr, 2)
'if string matches with array elements
If (matchType = 0 And sourcearr(outerindex, innerIndex) = actualStr) Or _
(matchType = 1 And Left(sourcearr(outerindex, innerIndex), Len(actualStr)) = actualStr) Or _
(matchType = 2 And Right(sourcearr(outerindex, innerIndex), Len(actualStr)) = actualStr) Or _
(matchType = 3 And InStr(sourcearr(outerindex, innerIndex), actualStr) <> 0) Then
increaseIndex = True
matchArrIndex(i) = outerindex
End If
Next
If increaseIndex Then
tempArrayIndex = tempArrayIndex + 1
increaseIndex = False
i = i + 1
End If
Next
'if no matches found, exit the function
If tempArrayIndex = 0 Then
Exit Function
End If
If LBound(sourcearr, 1) = 0 Then
tempArrayIndex = tempArrayIndex - 1

[COLOR=#ff0000]This is where it seems to fail i think[/COLOR]
End If
'resize temp array
ReDim Preserve temparray(LBound(sourcearr, 1) To tempArrayIndex, LBound(sourcearr, 2) To UBound(sourcearr, 2)) As Variant
'i = i - 1
CurrIndex = LBound(sourcearr, 1)
Dim j As Integer
j = LBound(matchArrIndex)
'store values in temp array
For i = CurrIndex To UBound(temparray)
For innerIndex = LBound(temparray, 1) To UBound(temparray, 2)
temparray(i, innerIndex) = sourcearr(matchArrIndex(j), innerIndex)
Next
j = j + 1
Next

'Application.ScreenUpdating = True
'Application.Workbooks("yesdatav2.xlsm").Sheets(Sheet14).Select
'Sheets(Sheet14).Range("A1").Resize(UBound(temparray) + 1, UBound(temparray, 4) + 1) = temparray
filter2dArray = temparray

Exit Function
errorHandler:
MsgBox "Error :" & Err.Description
End Function

Hope this is better with code tags and some one can help.