Текстовое поле поиска и список - 4

Question

У меня есть простой список акций, который работает с текстовым полем и списком. Когда я пишу слово в текстовое поле (например, фланец ), я вижу каждое название акции, которое включает одно и то же слово, в списке. (Я могу видеть каждое название акции, которое включает фланец слово в списке.)

Ниже коды хорошо работают на моем компьютере.

Но когда я отправляю этот лист Excel в другой компьютер, Listbox становится все меньше и меньше, когда я набираю любую клавишу клавиатуры.

Как можно избежать этой ошибки? Как я могу работать с этим листом Excel на всех р c без этой проблемы? У кого-нибудь есть идея?

Private Sub TextBox1_Change()

    'To avoid any screen update until the process is finished
    Application.ScreenUpdating = False
    'This method must make sure to turn this property back to True before exiting by
    '  always going through the exit_sub label

    On Error GoTo err_sub

    'This will be the string to filter by
    Dim filterSt As String: filterSt = Me.TextBox1.Text & ""

    'This is the number of the column to filter by
    Const filterCol As Long = 4 'This number can be changed as needed

    'This is the sheet to load the listbox from
    Dim dataSh As Worksheet: Set dataSh = Worksheets("T?mListe") 'The sheet name can be changed as needed

    'This is the number of columns that will be loaded from the sheet (starting with column A)
    Const colCount As Long = 6 'This constant allows you to easily include more/less columns in future

    'Determining how far down the sheet we must go
    Dim usedRng As Range: Set usedRng = dataSh.UsedRange
    Dim lastRow As Long: lastRow = usedRng.Row - 1 + usedRng.Rows.Count

    Dim c As Long

    'Getting the total width of all the columns on the sheet
    Dim colsTotWidth As Double: colsTotWidth = 0
    For c = 1 To colCount
        colsTotWidth = colsTotWidth + dataSh.Columns(c).ColumnWidth
    Next

    'Determining the desired total width for all the columns in the listbox
    Dim widthToUse As Double
    'Not sure why, but subtracting 4 ensured that the horizontal scrollbar would not appear
    widthToUse = Me.ListBox1.Width - 4
    If widthToUse < 0 Then widthToUse = 0

    'Making the widths of the listbox columns proportional to the corresponding column widths on the sheet;
    '  thus, the listbox columns will automatically adjust if the column widths on the sheet are changed
    Dim colWidthSt As String: colWidthSt = "" 'This will be the string used to set the listbox's column widths
    Dim totW As Double: totW = 1
    For c = 1 To colCount
        Dim w As Double
        If c = colCount Then 'Use the remaining width for the last column
            w = widthToUse - totW
        Else 'Calculate a proportional width
            w = dataSh.Columns(c).ColumnWidth / colsTotWidth * widthToUse
        End If

        'Rounding to 0 decimals and using an integer to avoid localisation issues
        '  when converting the width to a string
        Dim wInt As Long: wInt = Round(w, 0)
        If wInt < 1 And w > 0 Then wInt = 1
        totW = totW + wInt

        If c > 1 Then colWidthSt = colWidthSt & ","
        colWidthSt = colWidthSt & wInt
    Next

    'Reset the listbox
    Me.ListBox1.Clear
    Me.ListBox1.ColumnCount = colCount
    Me.ListBox1.ColumnWidths = colWidthSt
    Me.ListBox1.ColumnHeads = False

    'Reading the entire data sheet into memory
    Dim dataArr As Variant: dataArr = dataSh.UsedRange
    If Not IsArray(dataArr) Then dataArr = dataSh.Range("A1:A2")

    'If filterCol is beyond the last column in the data sheet, leave the list blank and simply exit
    If filterCol > UBound(dataArr, 2) Then GoTo exit_sub 'Do not use Exit Sub here, since we must turn ScreenUpdating back on

    'This array will store the rows that meet the filter condition
    ReDim filteredArr(1 To UBound(dataArr, 1), 1 To UBound(dataArr, 2)) 'Make room for the maximum possible size
    Dim filteredCount As Long: filteredCount = 0

    'Copy the matching rows from [dataArr] to [filteredArr]
    'IMPORTANT ASSUMPTION: The first row on the sheet is a header row
    Dim r As Long
    For r = 1 To lastRow
        'The first row will always be added to give the listbox a header
        If r > 1 And InStr(1, dataArr(r, filterCol) & "", filterSt, vbTextCompare) = 0 Then
            GoTo continue_for_r
        End If

        'NB: The Like operator is not used above in case [filterSt] has wildcard characters in it
        '    Also, the filtering above is case-insensitive
        '    (if needed, it can be changed to case-sensitive by changing the last parameter to vbBinaryCompare)

        filteredCount = filteredCount + 1
        For c = 1 To colCount
            filteredArr(filteredCount, c) = dataArr(r, c)
        Next

continue_for_r:
    Next

    'Copy [filteredArr] to a new array with the right dimensions
    If filteredCount > 0 Then
        'Unfortunately, Redim Preserve cannot be used here because it can only resize the last dimension;
        '  therefore, we must manually copy the filtered data to a new array
        ReDim filteredArr2(1 To filteredCount, 1 To colCount)
        For r = 1 To filteredCount
            For c = 1 To colCount
                filteredArr2(r, c) = filteredArr(r, c)
            Next
        Next

        Me.ListBox1.List = filteredArr2
    End If

ListBox1.Height = 772
ListBox1.Width = 1300
ListBox1.Top = 75

exit_sub:
    Application.ScreenUpdating = True
    Exit Sub

err_sub:
    MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & Err.Description
    Resume exit_sub 'To make sure that screen updating is turned back on

End Sub

Заранее спасибо.