Array - Subscript out of Range

0
votes

Working Image

https://i.stack.imgur.com/Q1WDu.png

Below code are a working code: -

Option Explicit

Private Sub UserForm_Initialize()
    Call loadList
    Me.tbox_srch_ID.SetFocus
End Sub

Private Sub cmd_add_Click()
    Call addItemByClick
End Sub

Private Sub lbox_ID_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Call addItemByClick
End Sub

Private Sub lbox_Word_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Call addItemByClick
End Sub

Private Sub cmb_cancel_Click()
    Unload Me
End Sub

Private Sub lbox_ID_Change()
    Me.lbox_Word.ListIndex = Me.lbox_ID.ListIndex
    Me.lbox_Word.TopIndex = Me.lbox_ID.TopIndex
End Sub

Private Sub lbox_Word_Change()
    Me.lbox_ID.ListIndex = Me.lbox_Word.ListIndex
    Me.lbox_ID.TopIndex = Me.lbox_Word.TopIndex
End Sub

Private Sub tbox_srch_ID_Keyup(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Me.tbox_srch_Word.Value = ""
    Call loadList
End Sub

Private Sub tbox_srch_Word_Keyup(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Me.tbox_srch_ID.Value = ""
    Call loadList
End Sub

Sub loadList()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim baseArray() As Variant
    Dim resultArray() As Variant
    Dim IDArray() As Variant
    Dim wordArray() As Variant
    Dim counter As Long, i As Long

    'On Error Resume Next
    
    'Clear current list boxes
    Me.lbox_ID.Clear
    Me.lbox_Word.Clear
    
    'Assign source list to an array, unfiltered
    baseArray = Sheet11.Range("tbl_WordList")
    
    'Set a default value to filter match counter
    counter = 0
    
    'Iterate through the source list, if search term is found add item to result array
    For i = LBound(baseArray) To UBound(baseArray)
        If ((InStr(1, baseArray(i, 1), Me.tbox_srch_ID.Value, vbTextCompare) > 0 And Me.tbox_srch_Word.Value = "") Or _
            (InStr(1, baseArray(i, 2), Me.tbox_srch_Word.Value, vbTextCompare) > 0 And tbox_srch_ID.Value = "")) Then
            
            counter = counter + 1
            
            ReDim Preserve resultArray(1 To 2, 1 To counter)
            resultArray(1, counter) = baseArray(i, 1)
            resultArray(2, counter) = baseArray(i, 2)
        End If
    Next i
    
    'If there is at least one match, separate result array to two arrays and load them to the listboxes
    If counter > 0 Then
        ReDim IDArray(1 To UBound(resultArray, 2), 1 To 1)
        ReDim wordArray(1 To UBound(resultArray, 2), 1 To 1)
        
        For i = LBound(resultArray, 2) To UBound(resultArray, 2)
            IDArray(i, 1) = resultArray(1, i)
            wordArray(i, 1) = resultArray(2, i)
        Next i
        
        Me.lbox_ID.List = IDArray
        Me.lbox_Word.List = wordArray
        
    End If
    
    On Error GoTo 0
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Sub addItemByClick()
    Call addWord
    ViewUpdateInvoice.Hide
End Sub

Sub addWord()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
  Sheet11.Unprotect password:="''784c23704f733130'"
  Sheet12.Unprotect password:="''784c23704f733130'"
  
Dim RowStart As Long
Dim RowEnd As Long

'Find rows

RowStart = Sheets("STOCK OUT").Columns("A").Find(lbox_ID.Value, _
  SearchOrder:=xlRows, LookAt:=xlWhole, SearchDirection:=xlNext, _
  LookIn:=xlValues).Row
  
RowEnd = Sheets("STOCK OUT").Columns("A").Find(lbox_ID.Value, _
  SearchOrder:=xlRows, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
  LookIn:=xlValues).Row + 1

'Clear range
Sheets("GENERATE TAX INVOICE").Range("B19:D28").ClearContents
Sheets("GENERATE TAX INVOICE").Range("G19:G28").ClearContents
Sheets("GENERATE TAX INVOICE").Range("I19:I28").ClearContents

'Copy values

Sheets("GENERATE TAX INVOICE").Range("B19").Resize(RowEnd - RowStart, 1).Value = _
Sheets("STOCK OUT").Range("E" & RowStart & ":E" & RowEnd).Value

Sheets("GENERATE TAX INVOICE").Range("G19").Resize(RowEnd - RowStart, 1).Value = _
Sheets("STOCK OUT").Range("J" & RowStart & ":J" & RowEnd).Value

Sheets("GENERATE TAX INVOICE").Range("I19").Resize(RowEnd - RowStart, 1).Value = _
Sheets("STOCK OUT").Range("L" & RowStart & ":L" & RowEnd).Value

'Sheets("GENERATE TAX INVOICE").Range("E19").Resize(RowEnd - RowStart, 6).Value = _
'Sheets("STOCK OUT").Range("H" & RowStart & ":M" & RowEnd).Value

Sheets("GENERATE TAX INVOICE").Range("J7").Value = Sheets("STOCK OUT").Range("B" _
& RowStart).Value

Sheets("GENERATE TAX INVOICE").Range("I7").Value = Sheets("STOCK OUT").Range("A" _
& RowStart)

Sheets("GENERATE TAX INVOICE").Range("A7").Value = Sheets("STOCK OUT").Range("C" _
& RowStart)

Unload ViewUpdateInvoice
    ActiveSheet.Protect password:="''784c23704f733130'", AllowFiltering:=True
    
    ActiveSheet.CommandButton1.Visible = True
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

The Above code is working best for first two Column (ListBox). 1: lbox_ID, 2: lbox_Word, But when I added third ListBox (lbox_Party) and modified the "loadList" Sub with the below code.:

Sub loadList()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim baseArray() As Variant
    Dim resultArray() As Variant
    Dim IDArray() As Variant
    Dim wordArray() As Variant
    Dim PartyArray() As Variant
    Dim counter As Long, i As Long

    'On Error Resume Next
    
    'Clear current list boxes
    Me.lbox_ID.Clear
    Me.lbox_Word.Clear
    Me.lbox_Party.Clear
    
    'Assign source list to an array, unfiltered
    baseArray = Sheet11.Range("tbl_WordList")
    
    'Set a default value to filter match counter
    counter = 0
    
    'Iterate through the source list, if search term is found add item to result array
    For i = LBound(baseArray) To UBound(baseArray)
        If ((InStr(1, baseArray(i, 1), Me.tbox_srch_ID.Value, vbTextCompare) > 0 And Me.tbox_srch_Word.Value = "") Or _
            (InStr(1, baseArray(i, 2), Me.tbox_srch_Word.Value, vbTextCompare) > 0 And tbox_srch_ID.Value = "")) Then

            counter = counter + 1

            ReDim Preserve resultArray(1 To 3, 1 To counter)
            resultArray(1, counter) = baseArray(i, 1)
            resultArray(2, counter) = baseArray(i, 2)
            resultArray(3, counter) = baseArray(i, 3)
        End If
    Next i
    
    'If there is at least one match, separate result array to two arrays and load them to the listboxes
    If counter > 0 Then
        ReDim IDArray(1 To UBound(resultArray, 2), 1 To 1)
        ReDim wordArray(1 To UBound(resultArray, 2), 1 To 1)
        ReDim PartyArray(1 To UBound(resultArray, 2), 1 To 1)
        
        For i = LBound(resultArray, 3) To UBound(resultArray, 3)
            IDArray(i, 1) = resultArray(1, i)
            wordArray(i, 1) = resultArray(2, i)
            PartyArray(i, 1) = resultArray(3, i)
        Next i
        
        Me.lbox_ID.List = IDArray
        Me.lbox_Word.List = wordArray
        Me.lbox_Party.List = PartyArray
        
    End If
    
    On Error GoTo 0
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

It is not working, and gives me a runtime error "9", Subscript out of range.

Please help.

1
excelvba
How do you know it's not working? Please add this information to the question. - Zev Spitz
Thank You for Quick Reply. Microsoft Visual Basic gives me a Run Time Error '9':, Subscript Out of range. But when I replace original code, it is working perfectly. - Prabhat Vishwas
Just on a very quick look, maybe counter should stay the same, counter + 1, not counter + 2? Include which line has the error if possible. - wazz
No error line showing,Only gives Run Time Error '9':, Subscript Out of range and stop opening user form. I think the main problem was start from "FOR" Element and LBound and UBound Arrey. I Could not figure-out the third line here. - Prabhat Vishwas
Title does not match question btw. - horst

1 Answers

0
votes

Change

ReDim IDArray(1 To UBound(resultArray, 3), 1 To 1)
ReDim wordArray(1 To UBound(resultArray, 3), 1 To 1)
ReDim PartyArray(1 To UBound(resultArray, 3), 1 To 1)

For i = LBound(resultArray, 3) To UBound(resultArray, 3)
    IDArray(i, 1) = resultArray(1, i)
    wordArray(i, 1) = resultArray(2, i)
    PartyArray(i, 1) = resultArray(3, i)
Next i

to

ReDim IDArray(1 To UBound(resultArray, 2), 1 To 1)
ReDim wordArray(1 To UBound(resultArray, 2), 1 To 1)
ReDim PartyArray(1 To UBound(resultArray, 2), 1 To 1)

For i = LBound(resultArray, 2) To UBound(resultArray, 2)
    IDArray(i, 1) = resultArray(1, i)
    wordArray(i, 1) = resultArray(2, i)
    PartyArray(i, 1) = resultArray(3, i)
Next i

Basically, what you want to do here with UBound, is getting the the largest available subscript for the indicated dimension of an array. Your Arrays only got 2 Dimensions. Hence the error Subscript Out of range. The dimensions of your arrays did not change when you added a third array.

Also, as @wazz said, counter + 1

Edit

Additionaly, in the last For loop, same problem. LBound(resultArray, 3) To UBound(resultArray, 3) There is no 3rd Dimension in resultArray. It has 2 Dimensions, as assigned in ReDim Preserve resultArray(1 To 3, 1 To counter)

Also, you will need to change if statement for the function to work properly:

If ((InStr(1, baseArray(i, 1), Me.tbox_srch_ID.Value, vbTextCompare) > 0 And Me.tbox_srch_Word.Value = "" And Me.tbox_srch_Party.Value = "") Or _
    (InStr(1, baseArray(i, 2), Me.tbox_srch_Word.Value, vbTextCompare) > 0 And Me.tbox_srch_ID.Value = "" And Me.tbox_srch_Party.Value = "") Or _
    (InStr(1, baseArray(i, 3), Me.tbox_srch_Party.Value, vbTextCompare) > 0 And Me.tbox_srch_ID.Value = "" And Me.tbox_srch_Word.Value = "")) Then

And add a tbox_srch_Party_Keyup Event, just like for the other two textboxes