VBA Vlookup медленно и сбоит - PullRequest
Новая
       12

VBA Vlookup медленно и сбоит

0 голосов
/ 25 октября 2018

Мой код VBA vlookup дает сбой в Excel и выполняется вечно, даже если размер файла составляет 519 КБ.Я пытался переключить его на индекс / совпадение, и все еще занимает вечность.Другие модули работают без суеты.Мне нужна VBA, а не формула в ячейке, потому что я использую содержимое ячеек vlookup в более поздних значениях 

Public Sub MatchRC()
    Dim DCP_nbr As String
    Dim Rootcause As String
    Dim xrange As Range
    Dim trange As Range
    Dim x As Long
    Dim hrange As Range
    Dim here As String
    Dim c As Range


    lastRow = ActiveWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

    'trange = ActiveWorkbook.Sheets("Sheet1").Range("J:K")

    For x = 2 To lastRow
     On Error Resume Next

         If ActiveWorkbook.Sheets("Sheet1").Cells(x, 2).Value <> "" Then
             'xrange = Range("x,B")
             DCP_nbr = ActiveWorkbook.Sheets("Sheet1").Cells(x, 2).Value
             here = Application.IfError(Application.WorksheetFunction.VLookup(DCP_nbr, ActiveWorkbook.Sheets("Sheet1").Range("J2:K2000"), 2, False), "Error")
             'Range("x,G").Value = here
             ActiveWorkbook.Sheets("Sheet1").Cells(x, 7).Value = here
        Else
            ActiveWorkbook.Sheets("Sheet1").Cells(x, 7).Value = "Error"
        End If
    Next x

End Sub

Ответы [ 2 ]

0 голосов
/ 25 октября 2018

Обобщая некоторые советы, приведенные в комментариях: 

Public Sub MatchRC()
    Dim DCP_nbr As String

    Dim c As Range
    Dim res As Variant, lookUpVals As Variant, retVals As Variant

    With ActiveWorkbook.Sheets("Sheet1") ' reference your sheet once and for all
        lookUpVals = .Range("J2:J2000").Value ' fill lookup array with referenced sheet range J2:J2000
        retVals = .Range("K2:K2000").Value 'fill return values array with referenced sheet range K2:K2000


        With .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)) ' reference referenced sheet column B cells from row 2 down to last not empty one
            For Each c In .SpecialCells(xlCellTypeConstants) ' loop through referenced range not empty values (assuming there will alwyas be at least two ...)
                 DCP_nbr = c.Value ' get current not empty value
                 res = Application.Match(DCP_nbr, lookUpVals) ' try searching current value in lookup array
                 If IsError(res) Then ' if not found
                    c.Offset(, 5) = "Error"
                 Else
                    c.Offset(, 5) = retVals(res, 1) ' write corresponding return values array item
                 End If
            Next
            If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).Offset(, 5) = "Error" ' place "Error" in column "G" cells corresponding to column "B" empty ones
        End With
    End With
End Sub
0 голосов
/ 25 октября 2018

Возможно, так вместо этого? 

Sub tgr()

    Dim ws As Worksheet

    Set ws = ActiveWorkbook.Sheets("Sheet1")
    With ws.Range("G2:G" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        If .Row < 2 Then Exit Sub   'No data
        .Formula = "=IF(B" & .Row & "<>"""",IFERROR(VLOOKUP(B" & .Row & ",$J:$K,2,FALSE),""Error""),""Error"")"
        .Value = .Value
    End With

End Sub
...