gpt4 book ai didi

vba - vba vlookup中的滞后

转载 作者:行者123 更新时间:2023-12-04 22:32:03 27 4
gpt4 key购买 nike

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

最佳答案

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

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

关于vba - vba vlookup中的滞后,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/51901557/

27 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com