Question

我的VBA vlookup代码崩溃了excel，即使文件大小为519 KB，也需要永久执行。我试图将其切换为索引/匹配，但仍然需要花费很多时间。其他模块完美运行，毫不费力。我需要vba，而不需要单元格中的公式，因为我在以后的countifs中使用了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

Answer 1

也许是这样吗？

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

Answer 2

总结评论中的一些建议：

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

VBA Vlookup缓慢且崩溃

2 个答案: