Me.ListBox1.Clear выдает ошибку времени выполнения '- 2147467259 (80004005)': ошибка не указана

Question

У нас на складе имеется 4000 различных материалов / оборудования.

Мы используем макрокоманду VBA, интегрированную со сканером штрих-кода, для выполнения всего процесса склада.

Мы суммируем все различные материалы / оборудование для другой рабочей книги отдельно благодаря кодам VBA (скажем, Сводная рабочая книга ).

Чтобы увидеть, сколько разных труб и сколько метров труб у нас на складе, вы следует щелкнуть на листе «ТРУБЫ» внутри сводной рабочей книги.

Для «ЭЛЕКТРИЧЕСКИХ МАТЕРИАЛОВ», «ФЛАНЦЫ», «ФИТИНГИ», «АКТИВЫ» и почти для 20 других групп запасов это одно и то же.

Все заголовки разделены и представляют собой все разные страницы в виде списка.

Также я перечисляю все заголовки ("ЭЛЕКТРИЧЕСКИЕ МАТЕРИАЛЫ", "ФЛАНЦЫ", "ФИТИНГИ", "АКТИВЫ", "ТРУБЫ" "et c.) на другой лист (скажем, DATA Sheet ).

Основная идея: использовать этот лист в качестве списка данных.

Все Цель вышеуказанных операций - проверка материалов / оборудования. легко и сколько разных продуктов у нас на складе. Но когда вы открываете «Сводную книгу», это сложно проверить. Каждая группа запасов включает не менее 150 различных материалов / оборудования.

Поэтому я создал еще один лист в Сводная рабочая тетрадь и назвал его Основной лист . Кроме того, я создал текстовое поле и список в нем.

Я выбираю всю информацию о запасах внутри листа ДАННЫХ из (A2: F4214) с именем «ДАННЫЕ».
Поэтому, когда я выбираю список на основном листе, я передать все «ДАННЫЕ», используя метод «ListFillRange».

Я использую 6 столбцов с заголовками.

1- Номер
2- Штрих-код №
3- Запас Название группы
4- Название запаса
5- Количество запаса
6- Измерение запаса (метр, шт, комплект, литр и т. Д. c.)

Код для использования текстового поля в качестве поиска Поле:

Private Sub TextBox1_Change()

Dim i As Long
Me.TextBox1.Text = StrConv(Me.TextBox1.Text, 1)
Me.ListBox1.Clear
For i = 2 To Application.WorksheetFunction.CountA(Sayfa281.Range("D:D"))
a = Len(Me.TextBox1.Text)
If Sayfa281.Cells(i, 4).Value Like "*" & TextBox1.Text & "*" Then
Me.ListBox1.AddItem Sayfa281.Cells(i, 4).Value
Me.ListBox1.List(ListBox1.ListCount - 1, 4) = Sayfa281.Cells(i, 4).Value
End If
Next i

End Sub

Это дало:

Ошибка времени выполнения '- 2147467259 (80004005)':
Неуказанная ошибка.

Когда Я нажимаю DEBUG, он показывает Me.ListBox1.Clear желтым цветом.

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

Answer 1

На основании комментариев и этой ссылки mrexcel.com создается впечатление, что ошибка времени выполнения 80004005 была вызвана использованием .ListFillRange для инициализации списка, который связывал список со заданный диапазон c в книге и запрет на удаление любых элементов из списка (либо через .RemoveItem, либо .Clear).

Если .ListFillRange не используется, список будет столбцы должны быть настроены вручную. Ниже приведен код, который можно использовать в обработчике событий изменения текстового поля для выполнения sh этого. Этот код немного обобщен c, так что его легко настроить на любой лист данных. Более простая версия этого кода просто установит свойство .ColumnWidths списка в жестко запрограммированную строку, что в основном устранит необходимость во всем коде после Dim c as Long и до Me.ListBox1.Clear, но я считаю, что этот код делает список более гибок для изменений в исходной таблице ...

Если .ListFillRange больше не используется, список будет пустым в начале и будет заполняться только после того, как пользователь начнет введите в текстовое поле. В настоящее время вся таблица данных будет загружена в список, если пользователь редактирует, а затем очищает текстовое поле, но это поведение можно легко изменить, добавив If filterSt = "" Then GoTo exit_sub после блока кода, который сбрасывает список.

Код пытается загружать данные быстрее, считывая сначала всю таблицу данных в память, а не считывая таблицу данных по одной ячейке за раз. Он также избегает использования метода .AddItem списка, чтобы сразу загрузить весь список и обойти ограничение 10 столбцов этого метода, как объяснено в

ответе StackOverflow (ограничение 10 столбцов может стать ошибка, если в будущем значение colCount будет увеличено).

Код использует 2 массива. Первый массив загружает все строки таблицы данных в память, а второй массив копирует строки, которые удовлетворяют условию фильтра. Во втором массиве строки и столбцы инвертируются, так что в конце его можно легко изменить в размере, используя ReDim Preserve (после того, как мы узнаем окончательное количество строк данных, которые нужно сохранить в массиве). Это преобразование было необходимо, поскольку ReDim Preserve позволяет изменять размер только последнего измерения, как объяснено в этого ответа StackOverflow . Спасибо, @TM, за совет на ответе StackOverflow !

Answer 2

Для ошибки усадки списка вы можете сделать следующее:

    ListBox1.Width = 1000
    ListBox1.Height = 800

непосредственно перед выходом из подпрограммы. У меня это сработало.

Answer 3

Спасибо @macrobook и @NoahBridge.

Ниже код работает для меня.

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 = 750
ListBox1.Width = 1800
ListBox1.Top = 100

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

Answer 4

для такого начинающего, как я, вы не представляете, насколько достойна ваша помощь.

Большое спасибо.

Коды работают хорошо. Я бы тоже попросил вас кое-что сказать.

В каждом типе текстового поля мой список становится все меньше и меньше
факт остается фактом, что информация переплетается между собой.

Я пытаюсь изменить некоторые параметры ниже кода,

   '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 = 0
    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

я не смог добиться. Есть ли у вас какие-либо предложения для этого.

Хорошего дня.