Как исправить ошибку «380 во время выполнения» в Excel VBA?

Question

Я добавляю более 10 столбцов в список в Excel VBA. Я продолжаю получать ошибку во время выполнения '380' -Неверное значение свойства. Это работает должным образом до столбца 9 в списке. Я не мог найти подходящее решение для этого где-либо еще. Кто-нибудь знает обходной путь для этой проблемы?

Private Sub txtSearch_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal 
Shift As Integer)
Dim rng As Range
Set rng = Range("Lookup")
Dim rw
Dim strText As String
strText = LCase(txtSearch.Text)
With ListBox1
.RowSource = ""
.ColumnCount = 12

 For Each rw In rng.Rows
    If InStr(LCase(Cells(rw.Row, 4)), strText) Then
        .AddItem Cells(rw.Row, 1).Value
        .List(ListBox1.ListCount - 1, 1) = Cells(rw.Row, 2).Value
        .List(ListBox1.ListCount - 1, 2) = Cells(rw.Row, 3).Value
        .List(ListBox1.ListCount - 1, 3) = Cells(rw.Row, 4).Value
        .List(ListBox1.ListCount - 1, 4) = Cells(rw.Row, 5).Value
        .List(ListBox1.ListCount - 1, 5) = Cells(rw.Row, 6).Value
        .List(ListBox1.ListCount - 1, 6) = Cells(rw.Row, 7).Value
        .List(ListBox1.ListCount - 1, 7) = Cells(rw.Row, 8).Value
        .List(ListBox1.ListCount - 1, 8) = Cells(rw.Row, 9).Value
        .List(ListBox1.ListCount - 1, 9) = Cells(rw.Row, 10).Value
        .List(ListBox1.ListCount - 1, 10) = Cells(rw.Row, 11).Value
        .List(ListBox1.ListCount - 1, 11) = Cells(rw.Row, 12).Value
        .List(ListBox1.ListCount - 1, 12) = Cells(rw.Row, 13).Value           
    End If
Next    

End With
End Sub

Answer 1

Я не знаю, исправит ли это все, но это определенно очистит это немного. Кроме того, я не уверен, с какого листа вы извлекаете Cells(rw.Row, 2).value. Но они могут иметь какое-то отношение к тому, почему это останавливается на полпути. Также, чтобы немного почистить, попробуйте дополнительный For Statement.

Private Sub txtSearch_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    Dim rng As Range: Set rng = Range("Lookup")
    Dim rw
    Dim strText As String: strText = LCase(txtSearch.Text)

    With ListBox1
        .RowSource = ""
        .ColumnCount = 21

        For Each rw In rng.Rows
            If InStr(LCase(Cells(rw.Row, 4)), strText) Then
                .AddItem Cells(rw.Row, 1).Value
                For x = 1 To 12  '''Change Worksheet to your Worksheet name
                    .List(ListBox1.ListCount - 1, x) = Worksheets("Sample").Cells(rw.Row, x + 1).Value2
                Next x
            End If
        Next

    End With

End Sub

Если это не поможет, попробуйте то, что сказал @Cyril с массивом.

Answer 2

Только что вернулся к вам ... немного долго, но вот общие мысли ...

Все это входит в код для элемента управления ActiveX:

Option Explicit

Sub ListBox1_Click()
    Dim rw As Range, strtext As String
    Dim arr As Variant, ai As Long, aj As Long 
    Dim brr As Variant, bi As Long, bj As Long
    strtext = "a" 'I used this when i did my testing
    ReDim arr(11, 0)
    For Each rw In Range("rng")
        If InStr(LCase(rw.Value), strtext) Then
            aj = findaj(arr)
            If Not IsEmpty(arr(1, aj)) Then
                aj = aj + 1
                ReDim Preserve arr(11, aj)
            End If
            For ai = 1 To 11
                arr(ai, aj) = Cells(rw.Row, ai + 1).Value
            Next ai
        End If
    Next rw
    ReDim brr(aj, 11)
    For bi = 0 To aj
        For bj = 1 To 11
            brr(bi, bj) = arr(bj, bi)
        Next bj
    Next bi
    ListBox1.ColumnCount = 11
    ListBox1.List = brr
End Sub

Private Function findaj(ByVal brr As Variant)
    Dim j As Long, meow As String
    j = 0
    Do While True
        On Error GoTo toll
        j = j + 1
        meow = brr(1, j)
    Loop
toll:
    findaj = j - 1
End Function

Итакздесь много чего происходит ... Я использую два отдельных массива из-за того, как редиммирующие массивы работают в VBA.Вы можете только обновить второй элемент массива, поэтому arr(ai,aj) может обновляться только aj только когда я redim preserve добавляю новую строку в мой массив.

Итак, мысоздайте массив (arr), который захватывает данные на основе ограничений VBA.Внутри этого массива мы используем функцию findaj, которая намеренно перехватывает ошибку, чтобы определить соответствующий последний столбец в arr (я выделил курсивом использование столбца, поскольку это не совсем так, ноэто имеет смысл пространственно, если подумать).

Затем вы конвертируете массив arr в brr в соответствующем порядке столбцов / строк.

После этого вы делаете .list = brr.

Answer 3

Я попробовал следующий код. Он применяет фильтры на листе Excel, но я не знаю, как перенести данные в список из листа Excel. Я пробовал объект таблицы, но не помогло.

Dim col As Byte
Dim src As Worksheet
Dim tgt As Worksheet
Dim lastRow As Integer
Dim tgt_lastRow As Integer
Dim filterRange As Range
Dim copyRange As Range
Dim j As Integer
Dim db As ListObject
Set db = ActiveSheet.ListObjects("DB_TABLE")

On Error Resume Next

Set src = ThisWorkbook.Sheets("Lookup")
Set tgt = ThisWorkbook.Sheets("TEMP")
src.AutoFilterMode = False
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
Set filterRange = src.Range("A1:ad" & lastRow)
Set copyRange = src.Range("A2:ad" & lastRow)
filterRange.AutoFilter field:=4, Criteria1:=Me.txtSearch.Value
tgt.Range("a1:ae1000").Clear
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A2")
tgt.Range("A1", tgt.Range("ae10000").End(xlDown)).Sort 
Key1:=tgt.Range("B1"), 
order1:=xlAscending, Header:=xlYes
src.Range("A1:ZZ1").Copy
tgt.Range("A1:ZZ1").PasteSpecial xlPasteFormats
tgt.Range("A1:ZZ1").PasteSpecial xlPasteFormulas
tgt_lastRow = tgt.Range("A" & 10000).End(xlUp).Row
Me.ListBox1.List = db

Можем ли мы решить эту проблему?