VBA程序卡死

颂风侯

下面这段vba程序，有个问题，当我删除一行的时候会卡死，所以在里面写了一个如果是删除行跳过模块不执行的函数，但是没用，帮看看怎么改

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   

    Dim KeyCell As Range
    Dim changedRow As Long
    Dim text As String
    Dim LastRowDest As Long
    Dim SearchRange As String
    ' Dim KeyCells As Range  ' 移除未使用的变量声明
   
    Dim FoundCell As Range
    Dim foundmatch As Boolean
    Dim i As Long
    Application.ScreenUpdating = False
   
   
  
    ' 设置工作表
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Sheets("Sheet2")

    ' 监控范围：B, C, D, E 列
    If Not Intersect(Target, wsSource.Range("B:E")) Is Nothing Then
        For Each KeyCell In Target  ' 遍历Target中的每个单元格
            changedRow = KeyCell.row  ' 修正：使用KeyCell.Row
            
            ' 检查是否是删除行操作
            If Not IsRowDeletion(wsSource, Target) Then
           

                ' 如果行数大于3
                If changedRow > 3 Then
                    ' 清空该行的H, I, J, K单元格的数据
                    wsSource.Range("H" & changedRow & ":K" & changedRow).ClearContents
                    ' 取消背景颜色设置
                    wsSource.Range("H" & changedRow & ":K" & changedRow).Interior.Color = xlNone
   
                    ' 合并B, C, D, E列内容为一个字符串
                    Dim arrValues As Variant
                    arrValues = wsSource.Range("B" & changedRow & ":E" & changedRow).Value
                    text = Join(Application.Transpose(Application.Transpose(arrValues)), ",")
                    ' 第一个判断：无缝钢管且不含锌
                    If CheckBasicCondition_wfgg(text) Then
                        wsSource.Cells(changedRow, "H").Value = "无缝钢管"
                        ' 后续条件分析并赋值I, J列
                        AssignStandards_I_wfgg text, changedRow '改标准I列
                        AssignMaterials_K_wfgg text, changedRow '改材质K列
                        AssignDimensions_J_wfgg text, changedRow '改规格J列
                    End If
   
                    ' 第二个判断：无缝钢管且含锌
                    If CheckBasicCondition_dxwfgg(text) Then
                        wsSource.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
                    End If
                End If
            End If
        Next KeyCell
    End If
    ' 确定变动的单元格是否在H到K列
   
   
' 监控范围：H, I, J, K 列
    If Not Intersect(Target, wsSource.Range("J:J")) Is Nothing Then
        For Each KeyCell In Intersect(Target, wsSource.Range("J:J"))
            changedRow = KeyCell.row
            
            ' 检查是否是删除行操作
            If Not IsRowDeletion(wsSource, Target) Then
            
                ' 如果行数大于3
                If changedRow > 3 Then
                    ' 清空该行的L单元格的数据
                    wsSource.Cells(changedRow, "L").ClearContents
                    
                    ' 确定查找范围
                    LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
                    SearchRange = "B1:E" & LastRowDest
                    
                    ' 初始化匹配标志
                    foundmatch = False
                    
                    ' 在Sheet2的B到E列查找匹配的行
                    For i = 1 To LastRowDest
                        ' 比较Sheet1的H列与Sheet2的B列，I列与C列，J列与D列，K列与E列
                        If wsSource.Cells(changedRow, "H").Value = wsDest.Cells(i, "B").Value And _
                           wsSource.Cells(changedRow, "I").Value = wsDest.Cells(i, "C").Value And _
                           wsSource.Cells(changedRow, "J").Value = wsDest.Cells(i, "D").Value And _
                           wsSource.Cells(changedRow, "K").Value = wsDest.Cells(i, "E").Value Then
                            ' 如果找到匹配的行，复制Sheet2的F列值到Sheet1的L列
                            wsSource.Cells(changedRow, "L").Value = wsDest.Cells(i, "F").Value
                            foundmatch = True
                            Exit For ' 找到匹配后退出循环
                        End If
                    Next i
                    
                    ' 如果没有找到匹配的行，L列保持清空状态
                End If
            End If
        Next KeyCell
    End If
   
   Application.ScreenUpdating = True
   
   
   
End Sub

' 辅助函数，用于检测是否正在进行删除行操作
Function IsRowDeletion(ws As Worksheet, Target As Range) As Boolean
    Dim r As Range
    On Error Resume Next ' 忽略错误
    For Each r In Target.Rows
        If Not r.EntireRow.Hidden Then
            IsRowDeletion = False
            Exit Function
        End If
    Next r
    IsRowDeletion = True
    On Error GoTo 0 ' 重置错误处理
End Function



'无缝钢管，不含镀锌的判断
Function CheckBasicCondition_wfgg(ByVal text As String) As Boolean
  If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And (InStr(text, "锌") = 0 And InStr(text, "zinc") = 0 And InStr(text, "galv") = 0) Then
  CheckBasicCondition_wfgg = True
  Else
  CheckBasicCondition_wfgg = False
  End If
End Function

'镀锌无缝钢管的判断
Function CheckBasicCondition_dxwfgg(ByVal text As String) As Boolean
  If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And (InStr(text, "锌") > 0 Or InStr(text, "zinc") > 0 Or InStr(text, "galv") > 0) Then
  CheckBasicCondition_dxwfgg = True
  Else
  CheckBasicCondition_dxwfgg = False
  End If
End Function

Sub AssignStandards_I_wfgg(ByVal text As String, ByVal row As Long)
    Application.ScreenUpdating = False
    ' 根据文本内容，为I列 标准 赋值
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    If InStr(text, "3405") > 0 Then
        wsSource.Cells(row, "I").Value = "SH/T3405"
    ElseIf InStr(text, "36.10") > 0 Then
        wsSource.Cells(row, "I").Value = "ASME B36.10"
    ElseIf InStr(text, "36.19") > 0 Then
        wsSource.Cells(row, "I").Value = "ASME B36.19"
    ElseIf InStr(text, "20553") > 0 Then
        Select Case True
            Case InStr(text, "a") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰa)"
            Case InStr(text, "b") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰb)"
            Case InStr(text, "Ⅱ") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅱ)"
            Case Else
                With wsSource.Cells(row, "C")
                     
                ' 设置背景颜色为黄色
                     .Interior.Color = RGB(255, 255, 0)
                    .Validation.Delete
                    .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:="HG/T20553(Ⅰa),HG/T20553(Ⅱ),HG/T20553(Ⅰb)"
                End With
        End Select
    ElseIf InStr(text, "17395") > 0 Then
        Select Case True
            Case InStr(text, "Ⅰ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅰ)"
            Case InStr(text, "Ⅱ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅱ)"
            Case InStr(text, "Ⅲ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅲ)"
            Case Else
                With wsSource.Cells(row, "C")
                  
                ' 设置背景颜色为黄色
                     .Interior.Color = RGB(255, 255, 0)
                    .Validation.Delete
                    .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:="GB/T17395(Ⅰ),GB/T17395(Ⅱ),GB/T17395(Ⅲ)"
                End With
            
        End Select
    Else
        ' 如果以上都没找到，设置下拉列表
        With wsSource.Cells(row, "C")
            
            ' 设置背景颜色为黄色
            .Interior.Color = RGB(255, 255, 0)
            .Validation.Delete
            .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
             xlBetween, Formula1:="SH/T3405,HG/T20553(Ⅰa),HG/T20553(Ⅱ),ASME B36.10,ASME B36.19,HG/T20553(Ⅰb)"
        End With
    End If
   
    Application.ScreenUpdating = True
End Sub

Sub AssignMaterials_K_wfgg(ByVal text As String, ByVal row As Long)
  ' 根据文本内容，为K列 材质 赋值
  Application.ScreenUpdating = False
  
  Dim wsSource As Worksheet
  Set wsSource = ThisWorkbook.Sheets("Sheet1")
  
  Select Case True
  Case InStr(text, "20") > 0 And InStr(text, "8163") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T8163"
  Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T9948"
  Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T3087"
  Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
    wsSource.Cells(row, "K").Value = "20G-GB/T5310"
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "9948") > 0
    wsSource.Cells(row, "K").Value = "15CrMoG-GB/T9948"
  Case InStr(text, "12Cr") > 0 Or InStr(text, "12cr") > 0
    wsSource.Cells(row, "K").Value = "12Cr1MoVG-GB/T5310"
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0)
    wsSource.Cells(row, "K").Value = "15CrMo-GB/T5310"
  Case InStr(text, "30403") > 0
    wsSource.Cells(row, "K").Value = "S30403-GB/T14976"
  Case InStr(text, "316") > 0
    wsSource.Cells(row, "K").Value = "S31603-GB/T14976"
  Case InStr(text, "310") > 0
    wsSource.Cells(row, "K").Value = "S31008-GB/T14976"
  Case InStr(text, "2205") > 0
    wsSource.Cells(row, "K").Value = "S22053-GB/T14976"
  Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
    wsSource.Cells(row, "K").Value = "S30408-GB/T13296"
  Case InStr(text, "304") > 0 And InStr(text, "312") > 0
    wsSource.Cells(row, "K").Value = "TP304-A312"
  Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
    wsSource.Cells(row, "K").Value = "S30408-GB/T14976"
   Case Else
        With wsSource.Cells(row, "E")
            
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
            .Validation.Delete
            .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="20-GB/T8163,20-GB/T3087,20G-GB/T5310,S30408-GB/T14976,S31603-GB/T14976,15CrMoG-GB/T5310,12Cr1MoVG-GB/T5310,S31008-GB/T14976,15CrMoG-GB/T9948,20-GB/T9948,S30403-GB/T14976,S22053-GB/T14976"
        End With
  End Select
  
  Application.ScreenUpdating = True
End Sub


Sub AssignDimensions_J_wfgg(ByVal text As String, ByVal row As Long)
    ' 根据文本内容，为J列 规格 赋值
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    Dim regex As Object
    Dim matches As Object
    Dim matchPattern As String
   
    Application.ScreenUpdating = False
   

    matchPattern = "(\d+(\.\d+)?)\s*[xX×*]\s*(\d+(\.\d+)?)"

    ' 创建正则表达式对象
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .pattern = matchPattern
        .Global = False
        '.IgnoreCase = True
    End With

    ' 执行正则表达式匹配
    If regex.Test(text) Then
        Set matches = regex.Execute(text)
        ' 如果有匹配项，生成指定格式的字符串
        If matches.Count > 0 And (InStr(text, "3087") Or InStr(text, "5310")) And InStr(text, "20") Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火,NB/T47019"
         ElseIf matches.Count > 0 And (InStr(text, "Cr") Or InStr(text, "cr")) Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火+回火,NB/T47019"
         ElseIf matches.Count > 0 Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2)
        End If
    Else
        With wsSource.Cells(row, "D")
            
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
        End With
        
    End If
   
    Application.ScreenUpdating = True
End Sub

FishC

看起来你的VBA程序在删除行时会卡死，可能是因为在`Worksheet_Change`事件中处理删除行的逻辑不够完善。你已经尝试通过`IsRowDeletion`函数来检测删除行操作，但似乎没有达到预期效果。以下是一些可能的改进建议：

1. **检查`IsRowDeletion`函数的逻辑**：确保该函数能够正确识别删除行的操作。你可以通过在函数中添加调试信息来确认它的行为。

2. **使用`Application.EnableEvents`**：在处理过程中禁用事件，以防止在更改单元格时触发其他事件。确保在代码结束时重新启用事件。

3. **优化`Worksheet_Change`事件的逻辑**：在处理删除行时，可能需要更精确地判断哪些操作需要跳过。

以下是一些具体的修改建议：

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    ' 你的代码逻辑...

ErrorHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

在`Worksheet_Change`事件的开头和结尾分别禁用和启用事件处理，以避免不必要的事件触发。

4. **改进`IsRowDeletion`函数**：确保该函数能够准确识别删除行的情况。你可以通过检查`Target`的行数变化来判断是否是删除操作。

希望这些建议能帮助你解决问题！如果还有其他问题，欢迎继续提问。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。

颂风侯

Option Explicit




Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim KeyCell As Range
    Dim changedRow As Long
    Dim text As String
    Dim LastRowDest As Long
    Dim SearchRange As String
    ' Dim KeyCells As Range  ' 移除未使用的变量声明
   
    Dim FoundCell As Range
    Dim foundmatch As Boolean
    Dim i As Long
    Application.ScreenUpdating = False
   
   
  
    ' 设置工作表
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
   
    ' 如果是删除行操作，则跳过
    If IsDeletingRows(Target) Then
        Application.ScreenUpdating = True
        Exit Sub
    End If

    ' 监控范围：B, C, D, E 列
    If Not Intersect(Target, wsSource.Range("B:E")) Is Nothing Then
        For Each KeyCell In Target  ' 遍历Target中的每个单元格
            changedRow = KeyCell.row  ' 修正：使用KeyCell.Row
            
            
           

                ' 如果行数大于3
                If changedRow > 3 Then
                    ' 清空该行的H, I, J, K单元格的数据
                    wsSource.Range("H" & changedRow & ":K" & changedRow).ClearContents
                    ' 取消背景颜色设置
                    wsSource.Range("H" & changedRow & ":K" & changedRow).Interior.Color = xlNone
   
                    ' 合并B, C, D, E列内容为一个字符串
                    Dim arrValues As Variant
                    arrValues = wsSource.Range("B" & changedRow & ":E" & changedRow).Value
                    text = Join(Application.Transpose(Application.Transpose(arrValues)), ",")
                    ' 第一个判断：无缝钢管且不含锌
                    If CheckBasicCondition_wfgg(text) Then
                        wsSource.Cells(changedRow, "H").Value = "无缝钢管"
                        ' 后续条件分析并赋值I, J列
                        AssignStandards_I_wfgg text, changedRow '改标准I列
                        AssignMaterials_K_wfgg text, changedRow '改材质K列
                        AssignDimensions_J_wfgg text, changedRow '改规格J列
                    End If
   
                    ' 第二个判断：无缝钢管且含锌
                    If CheckBasicCondition_dxwfgg(text) Then
                        wsSource.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
                    End If
                End If
            
        Next KeyCell
    End If
    ' 确定变动的单元格是否在H到K列
   
   
' 监控范围：H, I, J, K 列
    If Not Intersect(Target, wsSource.Range("J:J")) Is Nothing Then
        For Each KeyCell In Intersect(Target, wsSource.Range("J:J"))
            changedRow = KeyCell.row
            
            
            
                ' 如果行数大于3
                If changedRow > 3 Then
                    ' 清空该行的L单元格的数据
                    wsSource.Cells(changedRow, "L").ClearContents
                    
                    ' 确定查找范围
                    LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
                    SearchRange = "B1:E" & LastRowDest
                    
                    ' 初始化匹配标志
                    foundmatch = False
                    
                    ' 在Sheet2的B到E列查找匹配的行
                    For i = 1 To LastRowDest
                        ' 比较Sheet1的H列与Sheet2的B列，I列与C列，J列与D列，K列与E列
                        If wsSource.Cells(changedRow, "H").Value = wsDest.Cells(i, "B").Value And _
                           wsSource.Cells(changedRow, "I").Value = wsDest.Cells(i, "C").Value And _
                           wsSource.Cells(changedRow, "J").Value = wsDest.Cells(i, "D").Value And _
                           wsSource.Cells(changedRow, "K").Value = wsDest.Cells(i, "E").Value Then
                            ' 如果找到匹配的行，复制Sheet2的F列值到Sheet1的L列
                            wsSource.Cells(changedRow, "L").Value = wsDest.Cells(i, "F").Value
                            foundmatch = True
                            Exit For ' 找到匹配后退出循环
                        End If
                    Next i
                    
                    ' 如果没有找到匹配的行，L列保持清空状态
                End If
            
        Next KeyCell
    End If
   
   Application.ScreenUpdating = True
   
End Sub

' 辅助函数，用于检测是否正在进行删除行操作
Function IsDeletingRows(Target As Range) As Boolean
    Dim PrevCount As Long, CurrCount As Long
    PrevCount = Target.Count
    Application.EnableEvents = False ' 禁用事件触发，避免递归调用
    CurrCount = Target.Count
    Application.EnableEvents = True ' 重新启用事件触发
    IsDeletingRows = (PrevCount > CurrCount) ' 如果计数减少，说明正在删除行
End Function



'无缝钢管，不含镀锌的判断
Function CheckBasicCondition_wfgg(ByVal text As String) As Boolean
  If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And (InStr(text, "锌") = 0 And InStr(text, "zinc") = 0 And InStr(text, "galv") = 0) Then
  CheckBasicCondition_wfgg = True
  Else
  CheckBasicCondition_wfgg = False
  End If
End Function

'镀锌无缝钢管的判断
Function CheckBasicCondition_dxwfgg(ByVal text As String) As Boolean
  If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And (InStr(text, "锌") > 0 Or InStr(text, "zinc") > 0 Or InStr(text, "galv") > 0) Then
  CheckBasicCondition_dxwfgg = True
  Else
  CheckBasicCondition_dxwfgg = False
  End If
End Function

Sub AssignStandards_I_wfgg(ByVal text As String, ByVal row As Long)
    Application.ScreenUpdating = False
    ' 根据文本内容，为I列 标准 赋值
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    If InStr(text, "3405") > 0 Then
        wsSource.Cells(row, "I").Value = "SH/T3405"
    ElseIf InStr(text, "36.10") > 0 Then
        wsSource.Cells(row, "I").Value = "ASME B36.10"
    ElseIf InStr(text, "36.19") > 0 Then
        wsSource.Cells(row, "I").Value = "ASME B36.19"
    ElseIf InStr(text, "20553") > 0 Then
        Select Case True
            Case InStr(text, "a") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰa)"
            Case InStr(text, "b") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰb)"
            Case InStr(text, "Ⅱ") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅱ)"
            Case Else
                With wsSource.Cells(row, "C")
                     
                ' 设置背景颜色为黄色
                     .Interior.Color = RGB(255, 255, 0)
                    .Validation.Delete
                    .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:="HG/T20553(Ⅰa),HG/T20553(Ⅱ),HG/T20553(Ⅰb)"
                End With
        End Select
    ElseIf InStr(text, "17395") > 0 Then
        Select Case True
            Case InStr(text, "Ⅰ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅰ)"
            Case InStr(text, "Ⅱ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅱ)"
            Case InStr(text, "Ⅲ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅲ)"
            Case Else
                With wsSource.Cells(row, "C")
                  
                ' 设置背景颜色为黄色
                     .Interior.Color = RGB(255, 255, 0)
                    .Validation.Delete
                    .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:="GB/T17395(Ⅰ),GB/T17395(Ⅱ),GB/T17395(Ⅲ)"
                End With
            
        End Select
    Else
        ' 如果以上都没找到，设置下拉列表
        With wsSource.Cells(row, "C")
            
            ' 设置背景颜色为黄色
            .Interior.Color = RGB(255, 255, 0)
            .Validation.Delete
            .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
             xlBetween, Formula1:="SH/T3405,HG/T20553(Ⅰa),HG/T20553(Ⅱ),ASME B36.10,ASME B36.19,HG/T20553(Ⅰb)"
        End With
    End If
   
    Application.ScreenUpdating = True
End Sub

Sub AssignMaterials_K_wfgg(ByVal text As String, ByVal row As Long)
  ' 根据文本内容，为K列 材质 赋值
  Application.ScreenUpdating = False
  
  Dim wsSource As Worksheet
  Set wsSource = ThisWorkbook.Sheets("Sheet1")
  
  Select Case True
  Case InStr(text, "20") > 0 And InStr(text, "8163") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T8163"
  Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T9948"
  Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T3087"
  Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
    wsSource.Cells(row, "K").Value = "20G-GB/T5310"
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "9948") > 0
    wsSource.Cells(row, "K").Value = "15CrMoG-GB/T9948"
  Case InStr(text, "12Cr") > 0 Or InStr(text, "12cr") > 0
    wsSource.Cells(row, "K").Value = "12Cr1MoVG-GB/T5310"
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0)
    wsSource.Cells(row, "K").Value = "15CrMo-GB/T5310"
  Case InStr(text, "30403") > 0
    wsSource.Cells(row, "K").Value = "S30403-GB/T14976"
  Case InStr(text, "316") > 0
    wsSource.Cells(row, "K").Value = "S31603-GB/T14976"
  Case InStr(text, "310") > 0
    wsSource.Cells(row, "K").Value = "S31008-GB/T14976"
  Case InStr(text, "2205") > 0
    wsSource.Cells(row, "K").Value = "S22053-GB/T14976"
  Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
    wsSource.Cells(row, "K").Value = "S30408-GB/T13296"
  Case InStr(text, "304") > 0 And InStr(text, "312") > 0
    wsSource.Cells(row, "K").Value = "TP304-A312"
  Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
    wsSource.Cells(row, "K").Value = "S30408-GB/T14976"
   Case Else
        With wsSource.Cells(row, "E")
            
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
            .Validation.Delete
            .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="20-GB/T8163,20-GB/T3087,20G-GB/T5310,S30408-GB/T14976,S31603-GB/T14976,15CrMoG-GB/T5310,12Cr1MoVG-GB/T5310,S31008-GB/T14976,15CrMoG-GB/T9948,20-GB/T9948,S30403-GB/T14976,S22053-GB/T14976"
        End With
  End Select
  
  Application.ScreenUpdating = True
End Sub


Sub AssignDimensions_J_wfgg(ByVal text As String, ByVal row As Long)
    ' 根据文本内容，为J列 规格 赋值
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    Dim regex As Object
    Dim matches As Object
    Dim matchPattern As String
   
    Application.ScreenUpdating = False
   

    matchPattern = "(\d+(\.\d+)?)\s*[xX×*]\s*(\d+(\.\d+)?)"

    ' 创建正则表达式对象
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .pattern = matchPattern
        .Global = False
        '.IgnoreCase = True
    End With

    ' 执行正则表达式匹配
    If regex.Test(text) Then
        Set matches = regex.Execute(text)
        ' 如果有匹配项，生成指定格式的字符串
        If matches.Count > 0 And (InStr(text, "3087") Or InStr(text, "5310")) And InStr(text, "20") Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火,NB/T47019"
         ElseIf matches.Count > 0 And (InStr(text, "Cr") Or InStr(text, "cr")) Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火+回火,NB/T47019"
         ElseIf matches.Count > 0 Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2)
        End If
    Else
        With wsSource.Cells(row, "D")
            
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
        End With
        
    End If
   
    Application.ScreenUpdating = True
End Sub
删除行会卡死

FishC

颂风侯 发表于 2024-12-30 09:54
Option Explicit




Private Sub Worksheet_Cha ...

看起来你的VBA代码在删除行时会卡死，可能是因为`IsDeletingRows`函数的逻辑不正确。你可以尝试以下方法来改进代码：

1. **改进`IsDeletingRows`函数**：你可以通过检查`Target`的行数变化来判断是否是删除操作。当前的实现可能无法正确检测删除行。

2. **使用`Application.EnableEvents`**：在处理过程中禁用事件，以防止在更改单元格时触发其他事件。确保在代码结束时重新启用事件。

以下是一些具体的修改建议：

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    ' 如果是删除行操作，则跳过
    If IsDeletingRows(Target) Then
        GoTo ExitHandler
    End If

    ' 你的代码逻辑...

ExitHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    ' 错误处理逻辑
    Resume ExitHandler
End Sub

' 辅助函数，用于检测是否正在进行删除行操作
Function IsDeletingRows(Target As Range) As Boolean
    Dim r As Range
    On Error Resume Next
    For Each r In Target.Rows
        If r.EntireRow.Hidden Then
            IsDeletingRows = True
            Exit Function
        End If
    Next r
    IsDeletingRows = False
    On Error GoTo 0
End Function

在`Worksheet_Change`事件的开头和结尾分别禁用和启用事件处理，以避免不必要的事件触发。确保`IsDeletingRows`函数能够准确识别删除行的情况。你可以通过检查`Target`的行数变化来判断是否是删除操作。

希望这些建议能帮助你解决问题！如果还有其他问题，欢迎继续提问。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。

颂风侯

在excel的worksheet1有下列代码，问题是删除行的时候会卡死，请帮忙看下
Option Explicit




Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    Application.EnableEvents = False
   
   
    Dim KeyCell As Range
    Dim changedRow As Long
    Dim text As String
    Dim LastRowDest As Long
    Dim SearchRange As String
    ' Dim KeyCells As Range  ' 移除未使用的变量声明
   
    Dim FoundCell As Range
    Dim foundmatch As Boolean
    Dim i As Long
    Application.ScreenUpdating = False
   
   
  
    ' 设置工作表
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
   
    ' 如果是删除行操作，则跳过
    If IsDeletingRows(Target) Then
        GoTo ExitHandler
    End If

    ' 监控范围：B, C, D, E 列
    If Not Intersect(Target, wsSource.Range("B:E")) Is Nothing Then
        For Each KeyCell In Target  ' 遍历Target中的每个单元格
            changedRow = KeyCell.row  ' 修正：使用KeyCell.Row
            
            
           

                ' 如果行数大于3
                If changedRow > 3 Then
                    ' 清空该行的H, I, J, K单元格的数据
                    wsSource.Range("H" & changedRow & ":K" & changedRow).ClearContents
                    ' 取消背景颜色设置
                    wsSource.Range("H" & changedRow & ":K" & changedRow).Interior.Color = xlNone
   
                    ' 合并B, C, D, E列内容为一个字符串
                    Dim arrValues As Variant
                    arrValues = wsSource.Range("B" & changedRow & ":E" & changedRow).Value
                    text = Join(Application.Transpose(Application.Transpose(arrValues)), ",")
                    ' 第一个判断：无缝钢管且不含锌
                    If CheckBasicCondition_wfgg(text) Then
                        wsSource.Cells(changedRow, "H").Value = "无缝钢管"
                        ' 后续条件分析并赋值I, J列
                        AssignStandards_I_wfgg text, changedRow '改标准I列
                        AssignMaterials_K_wfgg text, changedRow '改材质K列
                        AssignDimensions_J_wfgg text, changedRow '改规格J列
                    End If
   
                    ' 第二个判断：无缝钢管且含锌
                    If CheckBasicCondition_dxwfgg(text) Then
                        wsSource.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
                    End If
                End If
            
        Next KeyCell
    End If
    ' 确定变动的单元格是否在H到K列
   
   
' 监控范围：H, I, J, K 列
    If Not Intersect(Target, wsSource.Range("J:J")) Is Nothing Then
        For Each KeyCell In Intersect(Target, wsSource.Range("J:J"))
            changedRow = KeyCell.row
            
            
            
                ' 如果行数大于3
                If changedRow > 3 Then
                    ' 清空该行的L单元格的数据
                    wsSource.Cells(changedRow, "L").ClearContents
                    
                    ' 确定查找范围
                    LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
                    SearchRange = "B1:E" & LastRowDest
                    
                    ' 初始化匹配标志
                    foundmatch = False
                    
                    ' 在Sheet2的B到E列查找匹配的行
                    For i = 1 To LastRowDest
                        ' 比较Sheet1的H列与Sheet2的B列，I列与C列，J列与D列，K列与E列
                        If wsSource.Cells(changedRow, "H").Value = wsDest.Cells(i, "B").Value And _
                           wsSource.Cells(changedRow, "I").Value = wsDest.Cells(i, "C").Value And _
                           wsSource.Cells(changedRow, "J").Value = wsDest.Cells(i, "D").Value And _
                           wsSource.Cells(changedRow, "K").Value = wsDest.Cells(i, "E").Value Then
                            ' 如果找到匹配的行，复制Sheet2的F列值到Sheet1的L列
                            wsSource.Cells(changedRow, "L").Value = wsDest.Cells(i, "F").Value
                            foundmatch = True
                            Exit For ' 找到匹配后退出循环
                        End If
                    Next i
                    
                    ' 如果没有找到匹配的行，L列保持清空状态
                End If
            
        Next KeyCell
    End If
   
   Application.ScreenUpdating = True
   
ExitHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    ' 错误处理逻辑
    Resume ExitHandler
   
   
   
   
End Sub

' 辅助函数，用于检测是否正在进行删除行操作
Function IsDeletingRows(Target As Range) As Boolean
    Dim r As Range
    On Error Resume Next
    For Each r In Target.Rows
        If r.EntireRow.Hidden Then
            IsDeletingRows = True
            Exit Function
        End If
    Next r
    IsDeletingRows = False
    On Error GoTo 0
End Function



'无缝钢管，不含镀锌的判断
Function CheckBasicCondition_wfgg(ByVal text As String) As Boolean
  If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And (InStr(text, "锌") = 0 And InStr(text, "zinc") = 0 And InStr(text, "galv") = 0) Then
  CheckBasicCondition_wfgg = True
  Else
  CheckBasicCondition_wfgg = False
  End If
End Function

'镀锌无缝钢管的判断
Function CheckBasicCondition_dxwfgg(ByVal text As String) As Boolean
  If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And (InStr(text, "锌") > 0 Or InStr(text, "zinc") > 0 Or InStr(text, "galv") > 0) Then
  CheckBasicCondition_dxwfgg = True
  Else
  CheckBasicCondition_dxwfgg = False
  End If
End Function

Sub AssignStandards_I_wfgg(ByVal text As String, ByVal row As Long)
    Application.ScreenUpdating = False
    ' 根据文本内容，为I列 标准 赋值
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    If InStr(text, "3405") > 0 Then
        wsSource.Cells(row, "I").Value = "SH/T3405"
    ElseIf InStr(text, "36.10") > 0 Then
        wsSource.Cells(row, "I").Value = "ASME B36.10"
    ElseIf InStr(text, "36.19") > 0 Then
        wsSource.Cells(row, "I").Value = "ASME B36.19"
    ElseIf InStr(text, "20553") > 0 Then
        Select Case True
            Case InStr(text, "a") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰa)"
            Case InStr(text, "b") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰb)"
            Case InStr(text, "Ⅱ") > 0
                wsSource.Cells(row, "I").Value = "HG/T20553(Ⅱ)"
            Case Else
                With wsSource.Cells(row, "C")
                     
                ' 设置背景颜色为黄色
                     .Interior.Color = RGB(255, 255, 0)
                    .Validation.Delete
                    .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:="HG/T20553(Ⅰa),HG/T20553(Ⅱ),HG/T20553(Ⅰb)"
                End With
        End Select
    ElseIf InStr(text, "17395") > 0 Then
        Select Case True
            Case InStr(text, "Ⅰ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅰ)"
            Case InStr(text, "Ⅱ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅱ)"
            Case InStr(text, "Ⅲ") > 0
                wsSource.Cells(row, "I").Value = "GB/T17395(Ⅲ)"
            Case Else
                With wsSource.Cells(row, "C")
                  
                ' 设置背景颜色为黄色
                     .Interior.Color = RGB(255, 255, 0)
                    .Validation.Delete
                    .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:="GB/T17395(Ⅰ),GB/T17395(Ⅱ),GB/T17395(Ⅲ)"
                End With
            
        End Select
    Else
        ' 如果以上都没找到，设置下拉列表
        With wsSource.Cells(row, "C")
            
            ' 设置背景颜色为黄色
            .Interior.Color = RGB(255, 255, 0)
            .Validation.Delete
            .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
             xlBetween, Formula1:="SH/T3405,HG/T20553(Ⅰa),HG/T20553(Ⅱ),ASME B36.10,ASME B36.19,HG/T20553(Ⅰb)"
        End With
    End If
   
    Application.ScreenUpdating = True
End Sub

Sub AssignMaterials_K_wfgg(ByVal text As String, ByVal row As Long)
  ' 根据文本内容，为K列 材质 赋值
  Application.ScreenUpdating = False
  
  Dim wsSource As Worksheet
  Set wsSource = ThisWorkbook.Sheets("Sheet1")
  
  Select Case True
  Case InStr(text, "20") > 0 And InStr(text, "8163") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T8163"
  Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T9948"
  Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
    wsSource.Cells(row, "K").Value = "20-GB/T3087"
  Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
    wsSource.Cells(row, "K").Value = "20G-GB/T5310"
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "9948") > 0
    wsSource.Cells(row, "K").Value = "15CrMoG-GB/T9948"
  Case InStr(text, "12Cr") > 0 Or InStr(text, "12cr") > 0
    wsSource.Cells(row, "K").Value = "12Cr1MoVG-GB/T5310"
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0)
    wsSource.Cells(row, "K").Value = "15CrMo-GB/T5310"
  Case InStr(text, "30403") > 0
    wsSource.Cells(row, "K").Value = "S30403-GB/T14976"
  Case InStr(text, "316") > 0
    wsSource.Cells(row, "K").Value = "S31603-GB/T14976"
  Case InStr(text, "310") > 0
    wsSource.Cells(row, "K").Value = "S31008-GB/T14976"
  Case InStr(text, "2205") > 0
    wsSource.Cells(row, "K").Value = "S22053-GB/T14976"
  Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
    wsSource.Cells(row, "K").Value = "S30408-GB/T13296"
  Case InStr(text, "304") > 0 And InStr(text, "312") > 0
    wsSource.Cells(row, "K").Value = "TP304-A312"
  Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
    wsSource.Cells(row, "K").Value = "S30408-GB/T14976"
   Case Else
        With wsSource.Cells(row, "E")
            
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
            .Validation.Delete
            .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="20-GB/T8163,20-GB/T3087,20G-GB/T5310,S30408-GB/T14976,S31603-GB/T14976,15CrMoG-GB/T5310,12Cr1MoVG-GB/T5310,S31008-GB/T14976,15CrMoG-GB/T9948,20-GB/T9948,S30403-GB/T14976,S22053-GB/T14976"
        End With
  End Select
  
  Application.ScreenUpdating = True
End Sub


Sub AssignDimensions_J_wfgg(ByVal text As String, ByVal row As Long)
    ' 根据文本内容，为J列 规格 赋值
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
    Dim regex As Object
    Dim matches As Object
    Dim matchPattern As String
   
    Application.ScreenUpdating = False
   

    matchPattern = "(\d+(\.\d+)?)\s*[xX×*]\s*(\d+(\.\d+)?)"

    ' 创建正则表达式对象
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .pattern = matchPattern
        .Global = False
        '.IgnoreCase = True
    End With

    ' 执行正则表达式匹配
    If regex.Test(text) Then
        Set matches = regex.Execute(text)
        ' 如果有匹配项，生成指定格式的字符串
        If matches.Count > 0 And (InStr(text, "3087") Or InStr(text, "5310")) And InStr(text, "20") Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火,NB/T47019"
         ElseIf matches.Count > 0 And (InStr(text, "Cr") Or InStr(text, "cr")) Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火+回火,NB/T47019"
         ElseIf matches.Count > 0 Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2)
        End If
    Else
        With wsSource.Cells(row, "D")
            
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
        End With
        
    End If
   
    Application.ScreenUpdating = True
End Sub