Кажется, что код работает вечно, и ошибка: переменная блока не установлена ​​(VBA)

Question

Я совершенно новичок в VBA, поэтому, пожалуйста, потерпите меня.

Я пытаюсь написать подпроцедуру, которая будет перебирать каждую строку в определенном столбце и сравнивать с критериями другого листа. например, если он содержит «x», будет возвращено значение. Однако, когда я пытаюсь запустить код, коды работают вечно и приводят к зависанию компьютера.

Вот код, который я написал до сих пор. Он продолжает выдавать ошибку: переменная объекта и переменная блока не установлены. PS: я получил ошибки при использовании «Application.WorksheetFunction.Index» и при чтении других потоков, было предложено удалить «WorksheetFunction». Я не уверен, является ли это причиной проблемы, и я также хотел бы уточнить обоснование удаления слов «WorksheetFunction»

Заранее большое спасибо!

Sub sub_inputData()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim lastrow as range 
lastrow = ws.Cells (ws.Rows.Count, 17).End (xlUp).row 

Dim rng As Range
Set rng = ws.Range("Q4:Q" & lastrow)
Dim rngCell As Range

On Error Resume Next

For Each rngCell In rng
    If rngCell.Offset(0, -13) = "x" Then
       rngCell = Application.Index(Sheets("Data").Range _
       ("D805:D813"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
       ("D805:D813"), 1))
    ElseIf rngCell.Offset(0, -13) = "y" Then
       rngCell = Application.Index(Sheets("Data").Range _
       ("D27:D34"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
       ("D27:D34"), 1))
    ElseIf rngCell.Offset(0, -13) = "z" Then
       rngCell = Application.Index(Sheets("Data").Range _
       ("D718:D726"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
       ("D718:D726"), 1))
    Else: rngCell = vbNullString
    End If

Next rngCell

     Call sub_code2
     Call sub_code3
     Set rngCell = Nothing
     Set rng = Nothing
End Sub 

Answer 1

другая возможность - использование функции Switch () :

Sub sub_inputData()
    Dim rngCell As Range, rangeToSearch As Range
    Dim val As Variant

    With ActiveSheet ' reference data sheet (better: With Worksheets("MyDataSheetName"))
        For Each rngCell In .Range("Q4", .Cells(.Rows.Count, "Q").End(xlUp)) ' loop throughreferenced sheet column Q cells from row 4 down to last not empty one
            val = rngCell.Offset(, -13).Value2 ' store column D current cell row value
            Set rangeToSearch = Sheets("Data").Range(Switch(val = "x", "D805:D813", val = "y", "D27:D34", val = "z", "D718:D726", True, "A1")) ' set range to search into with respect to stored value. set it to "A1" to signal no search is needed
            If rangeToSearch.Address <> "$A$1" Then ' if search is needed 
                rngCell.Value = Application.Index(rangeToSearch, Application.Match(rngCell.Offset(, -15).Value2, rangeToSearch, 1)) 'do the lookup
            Else
                rngCell.ClearContents ' clear current cell
            End If
        Next
    End With

    sub_code2 ' no need for 'Call' keyword
    sub_code3 ' no need for 'Call' keyword
End Sub

Answer 2

Похоже, что вы фактически выбираете диапазон поиска на основе значения в столбце D, а затем выполняете поиск по этому диапазону на основе значения в столбце B.

Если это так, вы можете сделать это полностью с помощью формул, что будет более эффективным, поскольку оно будет выполняться только в определенных ячейках, когда это необходимо (т. Е. Только при изменении их входных данных).

Вот пример использования таблиц и обозначений таблиц. Таблицы идеально подходят для этого, поскольку вам никогда не придется вносить изменения в формулы для обработки новых данных.

Формула в C2: =VLOOKUP([@ID],CHOOSE(VLOOKUP([@Condition],Conditions,2,FALSE),X,Y,Z),2,FALSE)

Эта формула использует таблицу «Условия» в E1: F3, чтобы определить, какую из других таблиц выполнить поиск. Я назвал эти другие таблицы X, Y и Z.

Answer 3

Проблема с вашим кодом, который был изменен здесь.
1) Dim lastrow As Long, а не Range
2) Else: не требуется, просто используйте Else
3) Set rngCell = Nothing & Set rng = Nothing не обязательно. См. эту ссылку для объяснения
4) Поскольку вы проверяете значение только в 1 ячейке, вы можете использовать Select Case для более чистого кода.
5) On Error Resume Next не годится для устранения ошибок в коде. Вы хотите увидеть ошибки, чтобы вы могли справиться с ними. Я рекомендую поискать do и не этого бита кода.

Sub sub_inputData()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim lastrow As Long: lastrow = ws.Range("Q" & ws.Rows.Count).End(xlUp).Row
Dim rng As Range: Set rng = ws.Range("Q4:Q" & lastrow)
Dim rngCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each rngCell In rng
    Select Case rngCell.Offset(0, -13)
        Case "x"
            rngCell = Application.Index(Sheets("Data").Range _
            ("D805:D813"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
            ("D805:D813"), 1))
        Case "y"
            rngCell = Application.Index(Sheets("Data").Range _
            ("D27:D34"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
            ("D27:D34"), 1))
        Case "z"
            rngCell = Application.Index(Sheets("Data").Range _
            ("D718:D726"), Application.Match(rngCell.Offset(0, -15), Sheets("Data").Range _
            ("D718:D726"), 1))
        Case Else
            rngCell = ""
    End Select
Next rngCell

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

     Call sub_code2
     Call sub_code3
End Sub