Question

我正在使用vlookup运行VBA代码，但是，尽管具有行的工作表的行数少于150行，但仍需要花费几秒钟来完成。

滞后主要出现在col 23的产生期间。

包含此代码的主表大约有2300行。

滞后是正常的还是我的编码效率低下使我得到最好的表现？

Private Sub Worksheet_Change(ByVal Target As Range)
    thisrow = Target.Row

    If Target.Column = 21 Then
        ' Generate the problem comments
        ' Declare some variables
        Dim CodeString As String
        Dim codeArr() As String
        Dim isPI As Boolean
        isPI = False

        ' Reset the impact, comment and origin cells
        Cells(thisrow, 22).Value = ""
        Cells(thisrow, 23).Value = ""
        Cells(thisrow, 25).Value = ""

        ' For esthetics, remove spaces in the cell
        Application.EnableEvents = False
        Cells(thisrow, 21).Value = Replace(Cells(thisrow, 21).Value, " ", "")
        Application.EnableEvents = True

        ' Get the code(s)
        CodeString = Cells(thisrow, 21).Value
        codeArr = Split(CodeString, Chr(59))

        ' Error code rows
        ErrLastRow = Sheets("lookup error codes").Cells(Sheets("lookup error codes").Rows.Count, 1).End(xlUp).Row

        ' There's more than one code
        If UBound(codeArr) > 0 Then
            For i = 0 To UBound(codeArr)
                If i < UBound(codeArr) Then
                    Cells(thisrow, 23).Value = Cells(thisrow, 23).Value & Application.WorksheetFunction.VLookup(CInt(codeArr(i)), Sheets("lookup error codes").Range("$A$2:$C$" & ErrLastRow).Value, 2, False) & "; "
                Else
                    Cells(thisrow, 23).Value = Cells(thisrow, 23).Value & Application.WorksheetFunction.VLookup(CInt(codeArr(i)), Sheets("lookup error codes").Range("$A$2:$C$" & ErrLastRow).Value, 2, False)
                End If
            Next i

            ' Check to see if anything is pay impacting
            For Each code In codeArr
                If Application.WorksheetFunction.VLookup(CInt(code), Sheets("lookup error codes").Range("$A$2:$C$" & ErrLastRow).Value, 3, False) <> "" Then
                    isPI = True

                    ' We only needed one
                    Exit For
                End If
            Next code
        Else
            ' There's only one code
            Cells(thisrow, 23).Value = Application.WorksheetFunction.VLookup(Cells(thisrow, 21).Value, Sheets("lookup error codes").Range("$A$2:$C$" & ErrLastRow).Value, 2, False)

            If Application.WorksheetFunction.VLookup(Cells(thisrow, 21).Value, Sheets("lookup error codes").Range("$A$2:$C$" & ErrLastRow).Value, 3, False) <> "" Then
                isPI = True
            End If
        End If

        ' There is a code that is pay impacting
        If isPI = True Then
            Cells(thisrow, 22).Value = "X"
        End If

        ' Modify the origin of error with common origins
        Dim Comment As Range, OrigErr As Range
        Set Comment = Range(Cells(thisrow, 23).Address)
        Set OrigErr = Range(Cells(thisrow, 25).Address)
        OrigErr.Value = ""
        If InStr(1, Comment.Value, "aaa", vbBinaryCompare) Or _
            InStr(1, Comment.Value, "bbb", vbBinaryCompare) Or _
            InStr(1, Comment.Value, "ccc", vbBinaryCompare) Then
                OrigErr.Value = "ddd"
        ElseIf InStr(1, Comment.Value, "eee", vbBinaryCompare) Then
            OrigErr.Value = "fff"
        End If
    End If
End Sub

Answer 1

将单元格的值更改为“”会触发更改事件。在更改工作表上的任何内容之前，请先禁用事件；如果更改的单元格影响其他公式，请禁用计算。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Count > 1 Then Exit Sub

    If Target.Column = 21 Then
        ' Generate the problem comments

        ' Declare some variables
        Dim CodeString As String, codeArr As Variant
        Dim isPI As Boolean, thisRow As Long

        On Error GoTo safe_exit
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual

        thisRow = Target.Row
        isPI = False

        ' Reset the impact, comment and origin cells
        Cells(thisRow, 22) = vbNullString
        Cells(thisRow, 23).Value = vbNullString
        Cells(thisRow, 25).Value = vbNullString

        ' For esthetics, remove spaces in the cell
        Cells(thisRow, 21) = Replace(Cells(thisRow, 21).Value, " ", vbNullString)

        ' Get the code(s)
        CodeString = Cells(thisRow, 21).Value
        codeArr = Split(CodeString, Chr(59))

        ' Error code rows
        ErrLastRow = Sheets("lookup error codes").Cells(Sheets("lookup error codes").Rows.Count, 1).End(xlUp).Row

        ' Doesn't matter if there is one code or many
        For i = LBound(codeArr) To UBound(codeArr)
            If i < UBound(codeArr) Then
                Cells(thisRow, 23).Value = Cells(thisRow, 23).Value & Application.VLookup(CLng(codeArr(i)), Sheets("lookup error codes").Range("A:C"), 2, False) & "; "
            Else
                Cells(thisRow, 23).Value = Cells(thisRow, 23).Value & Application.VLookup(CLng(codeArr(i)), Sheets("lookup error codes").Range("A:C"), 2, False)
            End If
        Next i

        ' Check to see if anything is pay impacting
        For Each code In codeArr
            If Application.VLookup(CLng(code), Sheets("lookup error codes").Range("A:C"), 3, False) <> "" Then
                ' There is a code that is pay impacting
                Cells(thisRow, 22).Value = "X"
                ' We only needed one
                Exit For
            End If
        Next code

        If isPI Then
        End If

        ' Modify the origin of error with common origins
        Dim Comment As Range, OrigErr As Range
        Set Comment = Cells(thisRow, 23)
        Set OrigErr = Cells(thisRow, 25)
        OrigErr.Value = vbNullString
        If InStr(1, Comment.Value, "aaa", vbBinaryCompare) Or _
           InStr(1, Comment.Value, "bbb", vbBinaryCompare) Or _
           InStr(1, Comment.Value, "ccc", vbBinaryCompare) Then
                OrigErr.Value = "ddd"
        ElseIf InStr(1, Comment.Value, "eee", vbBinaryCompare) Then
            OrigErr.Value = "fff"
        End If
    End If

safe_exit:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

End Sub

Answer 2

添加

$var

在代码开头，然后

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

到最后。

在VBA中滞后vlookup

2 个答案: