Fatal编程技术网
  • vba/
  • vba vlookup中的滞后

vba vlookup中的滞后

vba excel

vba vlookup中的滞后,vba,excel,Vba,Excel,我正在使用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

我正在使用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

Private子工作表\u更改（ByVal目标作为范围）
thisrow=Target.Row
如果Target.Column=21，则
'生成问题注释
'声明一些变量
Dim CodeString作为字符串
Dim codeArr（）作为字符串
Dim-isPI作为布尔值
isPI=False
'重置影响、注释和原始单元格
单元格（此行，22）。Value=“”
单元格（此行，23）。Value=“”
单元格（此行，25）。Value=“”
“为了美观起见，请删除单元中的空间
Application.EnableEvents=False
单元格（此行，21）.Value=Replace（单元格（此行，21）.Value，“，”）
Application.EnableEvents=True
'获取代码
CodeString=单元格（此行，21）.Value
codeArr=拆分（CodeString，Chr（59））
'错误代码行
ErrLastRow=Sheets（“查找错误代码”）。单元格（Sheets（“查找错误代码”）。Rows.Count，1）。End（xlUp）。Row
“有不止一个代码
如果UBound（codeArr）>0，则
对于i=0到uBond（codeArr）
如果我
添加

到代码的开头，然后

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
将单元格的值更改为“”将触发更改事件。在更改工作表上的任何内容之前禁用事件，如果更改的单元格影响其他公式，则禁用计算

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

选项显式
私有子工作表_更改（ByVal目标作为范围）
如果Target.Count>1，则退出Sub
如果Target.Column=21，则
'生成问题注释
'声明一些变量
Dim CodeString作为字符串，codeArr作为变量
将isPI设置为布尔值，此行设置为长
错误转到安全出口
Application.EnableEvents=False
Application.Calculation=xlCalculationManual
thisRow=Target.Row
isPI=False
'重置影响、注释和原始单元格
单元格（此行，22）=vbNullString
单元格（thisRow，23）。值=vbNullString
单元格（thisRow，25）。值=vbNullString
“为了美观起见，请删除单元中的空间
单元格（thisRow，21）=替换（单元格（thisRow，21）.Value，“，vbNullString）
'获取代码
CodeString=单元格（此行，21）.Value
codeArr=拆分（CodeString，Chr（59））
'错误代码行
ErrLastRow=Sheets（“查找错误代码”）。单元格（Sheets（“查找错误代码”）。Rows.Count，1）。End（xlUp）。Row
“不管是一个代码还是多个代码
对于i=LBound（codeArr）到UBound（codeArr）
如果我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