颂风侯 发表于 2024-12-29 19:16:44

看下vba错误

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
      
    Dim startTime As Long
    Dim currentTime As Long
    Dim waitTime As Single
    Dim changeDetected As Boolean
   
    waitTime = 0.1 ' 等待时间，单位秒
    startTime = GetTickCount ' 获取当前时间（毫秒）
   
    ' 检查是否在等待时间内有新的单元格变更
    Do While (GetTickCount - startTime) / 1000 < waitTime
      DoEvents ' 允许处理其他事件
      If WorksheetChangeInProgress Then ' 检查是否有新的变更
            changeDetected = True
            Exit Do While
      End If
    Loop
   
    If changeDetected Then Exit Sub ' 如果有新的变更，则退出子程序
      
      
    Dim changedRow As Long
    Dim text As String
    Dim LastRowDest As Long
    Dim SearchRange As String
    ' Dim KeyCells As Range' 移除未使用的变量声明
    Dim KeyCell 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

            ' 如果行数大于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
                  AssignMaterials_K_wfgg text, changedRow
                  AssignDimensions_J_wfgg text, changedRow
                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("H:K")) Is Nothing Then
      For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
            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 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, "I")
                     .Value = "请下拉选择"
                ' 设置背景颜色为黄色
                     .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, "I")
                     .Value = "请下拉选择"
                ' 设置背景颜色为黄色
                     .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, "I")
            .Value = "请下拉选择"
            ' 设置背景颜色为黄色
            .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, "K")
             .Value = "请下拉选择"
      ' 设置背景颜色为黄色
             .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*\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, "J")
             .Value = "请在前面写入正确规格,形式如88.9x5.6"
      ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
      End With
      
    End If
   
    Application.ScreenUpdating = True
End Sub
提示变量未定义

FishC 发表于 2024-12-29 19:19:21

根据您的VBA代码和错误提示，原因可能是由于变量`WorksheetChangeInProgress`没有在您的代码中定义。在VBA中，使用`Option Explicit`强制要求所有变量必须声明，因此未声明的变量会导致错误。

为了修正这个错误，您需要定义这个变量，或者使用另一个适当的方法替代它。同时，像`WorksheetChangeInProgress`这样的标志通常用于判断某个过程是否正在进行中。如果这是您原始代码逻辑的一部分，请确保它是正确的。另外，如果这部分逻辑不是必须的，您可以考虑将其删除。

您可以在代码的适当位置添加如下定义：

Dim WorksheetChangeInProgress As Boolean

或者，如果`WorksheetChangeInProgress`是一种状态标记，您可能需要实现相应的逻辑来设置这个标记。

希望这些建议能帮助您解决问题。如果还有其他未定义的变量，请逐一检查并确认它们在使用前已声明。

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

某一个“天” 发表于 2024-12-29 19:22:17


根据您的VBA代码和错误提示，原因可能是由于变量`WorksheetChangeInProgress`没有在您的代码中定义。

颂风侯 发表于 2024-12-29 19:30:31

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
      
    Dim startTime As Long
    Dim currentTime As Long
    Dim waitTime As Single
    Dim changeDetected As Boolean
    Dim WorksheetChangeInProgress As Boolean
   
    waitTime = 0.1 ' 等待时间，单位秒
    startTime = GetTickCount ' 获取当前时间（毫秒）
   
    ' 检查是否在等待时间内有新的单元格变更
    Do While (GetTickCount - startTime) / 1000 < waitTime
      DoEvents ' 允许处理其他事件
      If WorksheetChangeInProgress Then ' 检查是否有新的变更
            changeDetected = True
            Exit Do While
      End If
    Loop
   
    If changeDetected Then Exit Sub ' 如果有新的变更，则退出子程序
      
      
    Dim changedRow As Long
    Dim text As String
    Dim LastRowDest As Long
    Dim SearchRange As String
    ' Dim KeyCells As Range' 移除未使用的变量声明
    Dim KeyCell 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

            ' 如果行数大于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
                  AssignMaterials_K_wfgg text, changedRow
                  AssignDimensions_J_wfgg text, changedRow
                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("H:K")) Is Nothing Then
      For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
            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 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, "I")
                     .Value = "请下拉选择"
                ' 设置背景颜色为黄色
                     .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, "I")
                     .Value = "请下拉选择"
                ' 设置背景颜色为黄色
                     .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, "I")
            .Value = "请下拉选择"
            ' 设置背景颜色为黄色
            .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, "K")
             .Value = "请下拉选择"
      ' 设置背景颜色为黄色
             .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*\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, "J")
             .Value = "请在前面写入正确规格,形式如88.9x5.6"
      ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
      End With
      
    End If
   
    Application.ScreenUpdating = True
End Sub
提示变量未声明，是不是 GetTickCount 用的不对？

颂风侯 发表于 2024-12-29 19:40:25

Option Explicit

' 在模块的顶部声明GetTickCount函数
#If VBA7 Then
    Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
    Declare Function GetTickCount Lib "kernel32" () As Long
#End If


Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim startTime As Long
    Dim currentTime As Long
    Dim waitTime As Single
    Dim changeDetected As Boolean
    Dim WorksheetChangeInProgress As Boolean
   
   
    waitTime = 0.1 ' 等待时间，单位秒
    startTime = GetTickCount ' 获取当前时间（毫秒）
   
    ' 初始化变量
    changeDetected = False
    WorksheetChangeInProgress = False
   
    ' 检查是否在等待时间内有新的单元格变更
    Do While (GetTickCount - startTime) / 1000 < waitTime
      DoEvents ' 允许处理其他事件
      If WorksheetChangeInProgress Then ' 检查是否有新的变更
            changeDetected = True
            Exit Do While
      End If
    Loop
   
    If changeDetected Then Exit Sub ' 如果有新的变更，则退出子程序
      
      
    Dim changedRow As Long
    Dim text As String
    Dim LastRowDest As Long
    Dim SearchRange As String
    ' Dim KeyCells As Range' 移除未使用的变量声明
    Dim KeyCell 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

            ' 如果行数大于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
                  AssignMaterials_K_wfgg text, changedRow
                  AssignDimensions_J_wfgg text, changedRow
                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("H:K")) Is Nothing Then
      For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
            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 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, "I")
                     .Value = "请下拉选择"
                ' 设置背景颜色为黄色
                     .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, "I")
                     .Value = "请下拉选择"
                ' 设置背景颜色为黄色
                     .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, "I")
            .Value = "请下拉选择"
            ' 设置背景颜色为黄色
            .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, "K")
             .Value = "请下拉选择"
      ' 设置背景颜色为黄色
             .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*\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, "J")
             .Value = "请在前面写入正确规格,形式如88.9x5.6"
      ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
      End With
      
    End If
   
    Application.ScreenUpdating = True
End Sub
报错看看怎么改
页: [1]
查看完整版本: 看下vba错误