vba 对象调用失败

颂风侯 · 发表于 2024-12-31 10:50:44

Option Explicit

Dim IsDeleting As Boolean ' 全局变量，用于跟踪是否正在删除行

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet
Dim TargetCell As Range
Dim criteria As String
Dim i As Long
Dim listBoxItems As Variant

' 设置工作表引用
Set ws = ThisWorkbook.Sheets("Sheet1")

' 检查选中的单元格是否在第一列并且行数大于3
If Target.Column = 2 And Target.Count = 1 And Target.row > 3 Then
      ' 清除可能存在的任何现有下拉列表
      On Error Resume Next ' 如果没有找到下拉列表，则忽略错误
      Target.Validation.Delete
      On Error GoTo 0 ' 重置为默认的错误处理

      ' 设置数据验证以创建下拉列表
      With Target.Validation
         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
         xlBetween, Formula1:="无缝钢管, 无缝钢管(镀锌), 焊接钢管"
         .IgnoreBlank = True
         .InCellDropdown = True
         .ShowInput = True
         .ShowError = True
      End With
End If

'初始化，不显示文本框和列表框
ws.OLEObjects("ListBox1").Clear
ws.OLEObjects("TextBox1") = ""
ws.OLEObjects("ListBox1").Visible = False
ws.OLEObjects("TextBox1").Visible = False

' 检查是否只选择了D列的单元格，并且行数大于3
If Target.CountLarge = 1 And Target.Column = 4 And Target.row > 3 Then
      Set TargetCell = Target
      If IsEmpty(ws.Cells(TargetCell.row, "L").Value) Then ' L列
         ' 显示TextBox1和ListBox1
         With ws.OLEObjects("TextBox1")
            .Visible = True
            .Left = TargetCell.Left
            .Top = TargetCell.Top
            .Width = TargetCell.Width
            .Height = TargetCell.Height
            .text = ""
            .Activate
         End With

         With ws.OLEObjects("ListBox1")
            .Visible = True
            .Left = TargetCell.Left + TargetCell.Width
            .Top = TargetCell.Top
            .Width = 100 ' 设置合适的宽度
            .Height = TargetCell.Height
            .Clear
         End With

         ' 根据TextBox1输入更新ListBox1选项
         criteria = ws.OLEObjects("TextBox1").Object.text
         listBoxItems = Array()
         For i = 1 To ThisWorkbook.Sheets("Sheet2").Cells(ThisWorkbook.Sheets("Sheet2").Rows.Count, "B").End(xlUp).row
            If ThisWorkbook.Sheets("Sheet2").Cells(i, "D").Value Like criteria & "*" Then
                  listBoxItems = listBoxItems + Array(ThisWorkbook.Sheets("Sheet2").Cells(i, "B").Value & "|" & ThisWorkbook.Sheets("Sheet2").Cells(i, "C").Value & "|" & ThisWorkbook.Sheets("Sheet2").Cells(i, "E").Value)
            End If
         Next i
         ws.OLEObjects("ListBox1").Object.List = listBoxItems
      End If
' Else
      ' 隐藏TextBox1和ListBox1
'       ws.OLEObjects("TextBox1").Object.Visible = False
'       ws.OLEObjects("ListBox1").Object.Visible = False
End If
End Sub

Private Sub TextBox1_Change()
Dim criteria As String
Dim listBoxItems As Variant
Dim i As Long

criteria = ThisWorkbook.Sheets("Sheet1").OLEObjects("TextBox1").Object.text
listBoxItems = Array()
For i = 1 To ThisWorkbook.Sheets("Sheet2").Cells(ThisWorkbook.Sheets("Sheet2").Rows.Count, "B").End(xlUp).row
      If ThisWorkbook.Sheets("Sheet2").Cells(i, "D").Value Like criteria & "*" Then
         listBoxItems = listBoxItems + ThisWorkbook.Sheets("Sheet2").Cells(i, "B").text & "|" & ThisWorkbook.Sheets("Sheet2").Cells(i, "C").text & "|" & ThisWorkbook.Sheets("Sheet2").Cells(i, "E").text
      End If
Next i
ThisWorkbook.Sheets("Sheet1").OLEObjects("ListBox1").Object.List = listBoxItems
End Sub

Private Sub ListBox1_Click()
Dim selectedValue As String
Dim TargetCell As Range

selectedValue = ThisWorkbook.Sheets("Sheet1").OLEObjects("ListBox1").Object.Value
Set TargetCell = ThisWorkbook.Sheets("Sheet1").Range("D" & ThisWorkbook.Sheets("Sheet1").OLEObjects("TextBox1").Object.TopLeftCell.row)

' 将ListBox1选中的内容输入到选中单元格，并移除文本框和列表框
TargetCell.Offset(0, 7).Value = selectedValue ' L列
ThisWorkbook.Sheets("Sheet1").OLEObjects("TextBox1").Delete
ThisWorkbook.Sheets("Sheet1").OLEObjects("ListBox1").Delete
End Sub

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




            ' 如果行数大于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 = "无缝钢管(镀锌)"
                     ' 后续条件分析并赋值I, J列
                     AssignStandards_I_wfgg text, changedRow '改标准I列
                     AssignMaterials_K_wfgg text, changedRow '改材质K列
                     AssignDimensions_J_wfgg text, changedRow '改规格J列
                  End If

                  ' 第三个判断：焊接钢管
                  If CheckBasicCondition_hjgg(text) Then
                     wsSource.Cells(changedRow, "H").Value = "焊接钢管"
                     ' 后续条件分析并赋值I, J列
                     AssignStandards_I_wfgg text, changedRow '改标准I列
                     AssignMaterials_K_hjgg text, changedRow '改材质K列，单独做
                     AssignDimensions_J_wfgg text, changedRow '改规格J列
                  End If

                  ' 第四个判断：对焊弯头
                  If CheckBasicCondition_dhwt(text, changedRow) Then

                     ' 后续条件分析并赋值I, J列
                     AssignStandards_I_dhwt text, changedRow '改标准I列
                     AssignMaterials_K_dhwt text, changedRow '改材质K列，单独做
                     AssignDimensions_J_dhwt text, changedRow '改规格J列
                  End If

                  ' 第五个判断：承插焊弯头
                  If CheckBasicCondition_ccwt(text, changedRow) Then

                     ' 后续条件分析并赋值I, J列
                     AssignStandards_I_ccwt text, changedRow '改标准I列
                     AssignMaterials_K_ccwt text, changedRow '改材质K列，单独做
                     AssignDimensions_J_ccwt text, changedRow '改规格J列
                  End If

                  ' 第六个判断：内螺纹弯头
                  If CheckBasicCondition_nlwt(text, changedRow) Then

                     ' 后续条件分析并赋值I, J列
                     AssignStandards_I_ccwt text, changedRow '改标准I列
                     AssignMaterials_K_ccwt text, changedRow '改材质K列，单独做
                     AssignDimensions_J_nlwt text, changedRow '改规格J列
                  End If

                  ' 第六个判断：对焊等径三通
                  If CheckBasicCondition_dhdjst(text) Then
                     wsSource.Cells(changedRow, "H").Value = "对焊等径三通"
                     ' 后续条件分析并赋值I, J列
                     AssignStandards_I_dhwt text, changedRow '改标准I列
                     AssignMaterials_K_dhwt text, changedRow '改材质K列，单独做
                     AssignDimensions_J_dhdjst text, changedRow '改规格J列
                  End If

                  ' 第七个判断：对焊异径三通
                  If CheckBasicCondition_dhyjst(text) Then
                     wsSource.Cells(changedRow, "H").Value = "对焊异径三通"
                     ' 后续条件分析并赋值I, J列
                     AssignStandards_I_dhwt text, changedRow '改标准I列
                     AssignMaterials_K_dhwt text, changedRow '改材质K列，单独做
                     AssignDimensions_J_dhyjst text, changedRow '改规格J列
                  End If

                  ' 第八个判断：对焊异径管
                  If CheckBasicCondition_dhyjg(text, changedRow) Then

                     ' 后续条件分析并赋值I, J列
                     AssignStandards_I_dhwt text, changedRow '改标准I列
                     AssignMaterials_K_dhwt text, changedRow '改材质K列，单独做
                     AssignDimensions_J_dhyjst text, changedRow '改规格J列
                  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

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

ErrorHandler:
MsgBox "Error: " & Err.Description
Resume ExitHandler
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

'焊接钢管的判断
Function CheckBasicCondition_hjgg(ByVal text As String) As Boolean
  If InStr(text, "焊") > 0 And InStr(text, "钢管") > 0 Then
  CheckBasicCondition_hjgg = True
  Else
  CheckBasicCondition_hjgg = False
  End If
End Function

'对焊弯头的判断
Function CheckBasicCondition_dhwt(ByVal text As String, ByVal row As Long) As Boolean
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")

  If InStr(text, "对焊") > 0 And InStr(text, "弯头") > 0 And InStr(text, "45度") > 0 Then
wsSource.Cells(row, "H").Value = "对焊45度弯头"
CheckBasicCondition_dhwt = True
  ElseIf InStr(text, "对焊") > 0 And InStr(text, "弯头") > 0 And InStr(text, "180度") > 0 And InStr(text, "短") > 0 Then
wsSource.Cells(row, "H").Value = "对焊180度短半径弯头"
CheckBasicCondition_dhwt = True
  ElseIf InStr(text, "对焊") > 0 And InStr(text, "弯头") > 0 And InStr(text, "180度") > 0 Then
wsSource.Cells(row, "H").Value = "对焊180度弯头"
CheckBasicCondition_dhwt = True
  ElseIf InStr(text, "对焊") > 0 And InStr(text, "弯头") > 0 And InStr(text, "90度") > 0 And InStr(text, "3D") > 0 Then
wsSource.Cells(row, "H").Value = "对焊90度3D弯头"
CheckBasicCondition_dhwt = True
  ElseIf InStr(text, "对焊") > 0 And InStr(text, "弯头") > 0 And InStr(text, "90度") > 0 And InStr(text, "短") > 0 Then
wsSource.Cells(row, "H").Value = "对焊90度短半径弯头"
CheckBasicCondition_dhwt = True
  ElseIf InStr(text, "对焊") > 0 And InStr(text, "弯头") > 0 And InStr(text, "90度") > 0 And InStr(text, "长") > 0 Then
wsSource.Cells(row, "H").Value = "对焊90度长半径弯头"
CheckBasicCondition_dhwt = True

  Else
  CheckBasicCondition_dhwt = False
  End If
End Function

'承插焊弯头的判断
Function CheckBasicCondition_ccwt(ByVal text As String, ByVal row As Long) As Boolean
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")

  If InStr(text, "承插焊") > 0 And InStr(text, "弯头") > 0 And InStr(text, "45度") > 0 Then
wsSource.Cells(row, "H").Value = "承插焊45度弯头"
CheckBasicCondition_ccwt = True
  ElseIf InStr(text, "承插焊") > 0 And InStr(text, "弯头") > 0 And InStr(text, "90度") > 0 Then
wsSource.Cells(row, "H").Value = "承插焊90度弯头"
CheckBasicCondition_ccwt = True

  Else
  CheckBasicCondition_ccwt = False
  End If
End Function

'内螺纹弯头的判断
Function CheckBasicCondition_nlwt(ByVal text As String, ByVal row As Long) As Boolean
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")

  If InStr(text, "螺纹") > 0 And InStr(text, "弯头") > 0 And InStr(text, "90度") > 0 And InStr(text, "锌") > 0 Then
wsSource.Cells(row, "H").Value = "内螺纹90度弯头(镀锌)"
CheckBasicCondition_nlwt = True
  ElseIf InStr(text, "螺纹") > 0 And InStr(text, "弯头") > 0 And InStr(text, "45度") > 0 And InStr(text, "锌") > 0 Then
wsSource.Cells(row, "H").Value = "内螺纹45度弯头(镀锌)"
CheckBasicCondition_nlwt = True
  ElseIf InStr(text, "螺纹") > 0 And InStr(text, "弯头") > 0 And InStr(text, "45度") > 0 Then
wsSource.Cells(row, "H").Value = "内螺纹45度弯头"
CheckBasicCondition_nlwt = True
  ElseIf InStr(text, "螺纹") > 0 And InStr(text, "弯头") > 0 And InStr(text, "90度") > 0 Then
wsSource.Cells(row, "H").Value = "内螺纹90度弯头"
CheckBasicCondition_nlwt = True

  Else
  CheckBasicCondition_nlwt = False
  End If
End Function

'对焊等径三通的判断
Function CheckBasicCondition_dhdjst(ByVal text As String) As Boolean
  If InStr(text, "对焊") > 0 And InStr(text, "等径") > 0 And InStr(text, "三通") > 0 Then
  CheckBasicCondition_dhdjst = True
  Else
  CheckBasicCondition_dhdjst = False
  End If
End Function

'对焊异径三通的判断
Function CheckBasicCondition_dhyjst(ByVal text As String) As Boolean
  If InStr(text, "对焊") > 0 And InStr(text, "异径") > 0 And InStr(text, "三通") > 0 Then
  CheckBasicCondition_dhyjst = True
  Else
  CheckBasicCondition_dhyjst = False
  End If
End Function

'对焊异径管的判断
Function CheckBasicCondition_dhyjg(ByVal text As String, ByVal row As Long) As Boolean
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")

  If InStr(text, "对焊") > 0 And InStr(text, "异径管") > 0 And InStr(text, "同心") > 0 Then
wsSource.Cells(row, "H").Value = "对焊同心异径管"
CheckBasicCondition_dhyjg = True
  ElseIf InStr(text, "对焊") > 0 And InStr(text, "异径管") > 0 And InStr(text, "偏心") > 0 Then
wsSource.Cells(row, "H").Value = "对焊偏心异径管"
CheckBasicCondition_dhyjg = True

  Else
  CheckBasicCondition_dhyjg = 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"
      wsSource.Cells(row, "C").Interior.Color = xlNone
ElseIf InStr(text, "36.10") > 0 Then
      wsSource.Cells(row, "I").Value = "ASME B36.10"
      wsSource.Cells(row, "C").Interior.Color = xlNone
ElseIf InStr(text, "36.19") > 0 Then
      wsSource.Cells(row, "I").Value = "ASME B36.19"
      wsSource.Cells(row, "C").Interior.Color = xlNone
ElseIf InStr(text, "20553") > 0 Then
      Select Case True
         Case InStr(text, "a") > 0
            wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰa)"
            wsSource.Cells(row, "C").Interior.Color = xlNone
         Case InStr(text, "b") > 0
            wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰb)"
            wsSource.Cells(row, "C").Interior.Color = xlNone
         Case InStr(text, "Ⅱ") > 0
            wsSource.Cells(row, "I").Value = "HG/T20553(Ⅱ)"
            wsSource.Cells(row, "C").Interior.Color = xlNone
         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(Ⅰ)"
            wsSource.Cells(row, "C").Interior.Color = xlNone
         Case InStr(text, "Ⅱ") > 0
            wsSource.Cells(row, "I").Value = "GB/T17395(Ⅱ)"
            wsSource.Cells(row, "C").Interior.Color = xlNone
         Case InStr(text, "Ⅲ") > 0
            wsSource.Cells(row, "I").Value = "GB/T17395(Ⅲ)"
            wsSource.Cells(row, "C").Interior.Color = xlNone
         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 AssignStandards_I_dhwt(ByVal text As String, ByVal row As Long)
Application.ScreenUpdating = False
' 根据文本内容，为I列标准赋值
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")

If InStr(text, "16.9") > 0 Then
      wsSource.Cells(row, "I").Value = "ASME B16.9"
      wsSource.Cells(row, "C").Interior.Color = xlNone
ElseIf InStr(text, "12459") > 0 Then
      wsSource.Cells(row, "I").Value = "GB/T12459"
      wsSource.Cells(row, "C").Interior.Color = xlNone
ElseIf InStr(text, "3408") > 0 Then
      wsSource.Cells(row, "I").Value = "SH/T3408"
      wsSource.Cells(row, "C").Interior.Color = xlNone

Else
      ' 如果以上都没找到，设置下拉列表
      With wsSource.Cells(row, "C")

         ' 设置背景颜色为黄色
         .Interior.Color = RGB(255, 255, 0)
         .Validation.Delete
         .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
         xlBetween, Formula1:="GB/T12459,SH/T3408,ASME B16.9"
      End With
End If

Application.ScreenUpdating = True
End Sub

'改承插焊弯头标准
Sub AssignStandards_I_ccwt(ByVal text As String, ByVal row As Long)
Application.ScreenUpdating = False
' 根据文本内容，为I列标准赋值
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")

If InStr(text, "16.11") > 0 Then
      wsSource.Cells(row, "I").Value = "ASME B16.11"
      wsSource.Cells(row, "C").Interior.Color = xlNone
ElseIf InStr(text, "14383") > 0 Then
      wsSource.Cells(row, "I").Value = "GB/T14383"
      wsSource.Cells(row, "C").Interior.Color = xlNone
ElseIf InStr(text, "3410") > 0 Then
      wsSource.Cells(row, "I").Value = "SH/T3410"
      wsSource.Cells(row, "C").Interior.Color = xlNone

Else
      ' 如果以上都没找到，设置下拉列表
      With wsSource.Cells(row, "C")

         ' 设置背景颜色为黄色
         .Interior.Color = RGB(255, 255, 0)
         .Validation.Delete
         .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
         xlBetween, Formula1:="ASME B16.11,GB/T14383,SH/T3410"
      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"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
wsSource.Cells(row, "K").Value = "20-GB/T9948"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
wsSource.Cells(row, "K").Value = "20-GB/T3087"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
wsSource.Cells(row, "K").Value = "20G-GB/T5310"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "9948") > 0
wsSource.Cells(row, "K").Value = "15CrMoG-GB/T9948"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "12Cr") > 0 Or InStr(text, "12cr") > 0
wsSource.Cells(row, "K").Value = "12Cr1MoVG-GB/T5310"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0)
wsSource.Cells(row, "K").Value = "15CrMo-GB/T5310"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "30403") > 0
wsSource.Cells(row, "K").Value = "S30403-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "316") > 0
wsSource.Cells(row, "K").Value = "S31603-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "310") > 0
wsSource.Cells(row, "K").Value = "S31008-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "2205") > 0
wsSource.Cells(row, "K").Value = "S22053-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
wsSource.Cells(row, "K").Value = "S30408-GB/T13296"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "304") > 0 And InStr(text, "312") > 0
wsSource.Cells(row, "K").Value = "TP304-A312"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
wsSource.Cells(row, "K").Value = "S30408-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
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 AssignMaterials_K_hjgg(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, "Q235B") > 0 And InStr(text, "3091") > 0
wsSource.Cells(row, "K").Value = "Q235B-GB/T3091"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20") > 0 And InStr(text, "3091") > 0
wsSource.Cells(row, "K").Value = "20-GB/T3091"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "Q235B") > 0 And InStr(text, "13793") > 0
wsSource.Cells(row, "K").Value = "Q235B-GB/T13793"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "Q235B") > 0 And InStr(text, "5037") > 0
wsSource.Cells(row, "K").Value = "Q235B-SY/T5037"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "304") > 0 Or InStr(text, "I类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S30408-I类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "304") > 0 Or InStr(text, "IV类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S30408-IV类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "304") > 0 Or InStr(text, "Ⅴ类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S30408-Ⅴ类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "310") > 0 Or InStr(text, "I类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S31008-I类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "310") > 0 Or InStr(text, "IV类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S31008-IV类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "310") > 0 Or InStr(text, "Ⅴ类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S31008-Ⅴ类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
Case (InStr(text, "316") > 0 Or InStr(text, "I类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S31603-I类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "316") > 0 Or InStr(text, "IV类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S31603-IV类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "316") > 0 Or InStr(text, "Ⅴ类") > 0) And InStr(text, "12771") > 0
wsSource.Cells(row, "K").Value = "S31603-Ⅴ类-GB/T12771"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "304") > 0 And InStr(text, "20878") > 0
wsSource.Cells(row, "K").Value = "S30408-GB/T20878"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "316") > 0 And InStr(text, "20878") > 0
wsSource.Cells(row, "K").Value = "S31603-GB/T20878"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "310") > 0 And InStr(text, "20878") > 0
wsSource.Cells(row, "K").Value = "S31008-GB/T20878"
wsSource.Cells(row, "E").Interior.Color = xlNone


  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/T3091,Q235B-GB/T3091,Q235B-GB/T13793,Q235B-SY/T5037,S30408-I类-GB/T12771,S30408-IV类-GB/T12771,S30408-Ⅴ类-GB/T12771,S31008-I类-GB/T12771,S31008-IV类-GB/T12771,S31008-Ⅴ类-GB/T12771,S31603-I类-GB/T12771,S31603-IV类-GB/T12771,S31603-Ⅴ类-GB/T12771,S30408-GB/T20878,S31008-GB/T20878,S31603-GB/T20878"
      End With
  End Select

  Application.ScreenUpdating = True
End Sub

'给对焊弯头赋予材质
Sub AssignMaterials_K_dhwt(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"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
wsSource.Cells(row, "K").Value = "20-GB/T3087"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
wsSource.Cells(row, "K").Value = "20G-GB/T5310"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20") > 0 And InStr(text, "6479") > 0
wsSource.Cells(row, "K").Value = "20-GB/T6479"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
wsSource.Cells(row, "K").Value = "20-GB/T9948"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "5310") > 0
wsSource.Cells(row, "K").Value = "15CrMoG-GB/T5310"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "12Cr") > 0 Or InStr(text, "12cr") > 0) And InStr(text, "5310") > 0
wsSource.Cells(row, "K").Value = "12Cr1MoVG-GB/T5310"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "9948") > 0
wsSource.Cells(row, "K").Value = "15CrMo-GB/T9948"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "Q235B") > 0 And InStr(text, "3091") > 0
wsSource.Cells(row, "K").Value = "Q235B-GB/T3091"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "Q345D") > 0 And InStr(text, "6479") > 0
wsSource.Cells(row, "K").Value = "Q345D-GB/T6479"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "Q345E") > 0 And InStr(text, "6479") > 0
wsSource.Cells(row, "K").Value = "Q345E-GB/T6479"
wsSource.Cells(row, "E").Interior.Color = xlNone

  Case InStr(text, "30408") > 0 And InStr(text, "14976") > 0
wsSource.Cells(row, "K").Value = "S30408-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "31603") > 0 And InStr(text, "14976") > 0
wsSource.Cells(row, "K").Value = "S31603-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "31608") > 0 And InStr(text, "14976") > 0
wsSource.Cells(row, "K").Value = "S31608-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "30403") > 0 And InStr(text, "14976") > 0
wsSource.Cells(row, "K").Value = "S30403-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "2205") > 0 And InStr(text, "14976") > 0
wsSource.Cells(row, "K").Value = "S22053-GB/T14976"
wsSource.Cells(row, "E").Interior.Color = xlNone

  Case InStr(text, "31603") > 0 And InStr(text, "20878") > 0
wsSource.Cells(row, "K").Value = "S31603-GB/T20878"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "31608") > 0 And InStr(text, "20878") > 0
wsSource.Cells(row, "K").Value = "S31608-GB/T20878"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "2205") > 0 And InStr(text, "20878") > 0
wsSource.Cells(row, "K").Value = "S22053-GB/T20878"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "30408") > 0 And InStr(text, "20878") > 0
wsSource.Cells(row, "K").Value = "S30408-GB/T20878"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "31008") > 0 And InStr(text, "13296") > 0
wsSource.Cells(row, "K").Value = "S31008-GB/T13296"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "2205") > 0 And InStr(text, "13401") > 0
wsSource.Cells(row, "K").Value = "SF2205-GB/T13401"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "WPB") > 0 And InStr(text, "234") > 0
wsSource.Cells(row, "K").Value = "WPB-A234"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "WP304") > 0 And InStr(text, "A403") > 0
wsSource.Cells(row, "K").Value = "WP304-WX-A403"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "WPL6") > 0 And InStr(text, "A420") > 0
wsSource.Cells(row, "K").Value = "Gr.WPL6-S-A420"
wsSource.Cells(row, "E").Interior.Color = xlNone

  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,20-GB/T6479,20-GB/T9948,15CrMoG-GB/T5310,12Cr1MoVG-GB/T5310,15CrMo-GB/T9948,Q235B-GB/T3091,Q345D-GB/T6479,Q345E-GB/T6479,S30408-GB/T14976,S31603-GB/T14976,S31608-GB/T14976,S30403-GB/T14976,S22053-GB/T14976,S31603-GB/T20878,S31608-GB/T20878,S22053-GB/T20878,S25073-GB/T20878,S22053-GB/T21833,S30408-GB/T20878,S31008-GB/T13296,SF2205-GB/T13401,WPB-A234,Gr.WPL6-S-A420,WP304-WX-A403"
      End With
  End Select

  Application.ScreenUpdating = True
End Sub

'给承插焊弯头赋予材质
Sub AssignMaterials_K_ccwt(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
wsSource.Cells(row, "K").Value = "20Ⅱ-NB/T47008"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "20Ⅲ") > 0
wsSource.Cells(row, "K").Value = "20Ⅲ-NB/T47008"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "30403Ⅱ") > 0
wsSource.Cells(row, "K").Value = "S30403Ⅱ-NB/T47010"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "S30408Ⅱ") > 0
wsSource.Cells(row, "K").Value = "S30408Ⅱ-NB/T47010"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "S31603Ⅱ") > 0
wsSource.Cells(row, "K").Value = "S31603Ⅱ-NB/T47010"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "12Cr") > 0 Or InStr(text, "12cr") > 0) And InStr(text, "Ⅱ") > 0
wsSource.Cells(row, "K").Value = "12Cr1MoVⅡ-NB/T47008"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "12Cr") > 0 Or InStr(text, "12cr") > 0) And InStr(text, "Ⅲ") > 0
wsSource.Cells(row, "K").Value = "12Cr1MoVⅢ-NB/T47008"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "Ⅱ") > 0
wsSource.Cells(row, "K").Value = "15CrMoⅡ-NB/T47008"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "Ⅲ") > 0
wsSource.Cells(row, "K").Value = "15CrMoⅢ-NB/T47008"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "16Mn") > 0 Or InStr(text, "16MN") > 0) And InStr(text, "Ⅲ") > 0
wsSource.Cells(row, "K").Value = "16MnⅢ-NB/T47008"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "105Ⅱ") > 0
wsSource.Cells(row, "K").Value = "A105Ⅱ"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "105Ⅲ") > 0
wsSource.Cells(row, "K").Value = "A105Ⅲ"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case (InStr(text, "304L") > 0 Or InStr(text, "304l") > 0) And InStr(text, "182") > 0
wsSource.Cells(row, "K").Value = "F304L-A182"
wsSource.Cells(row, "E").Interior.Color = xlNone
  Case InStr(text, "304") > 0 And InStr(text, "182") > 0
wsSource.Cells(row, "K").Value = "F304-A182"
wsSource.Cells(row, "E").Interior.Color = xlNone


  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Ⅱ-NB/T47008,20Ⅲ-NB/T47008,S30403Ⅱ-NB/T47010,S30408Ⅱ-NB/T47010,S31603Ⅱ-NB/T47010,12Cr1MoVⅡ-NB/T47008,12Cr1MoVⅢ-NB/T47008,15CrMoⅡ-NB/T47008,15CrMoⅢ-NB/T47008,16MnⅢ-NB/T47008,A105Ⅱ,A105Ⅲ,F304-A182,F304L-A182"
      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
      wsSource.Cells(row, "D").Interior.Color = xlNone
      If Not wsSource.Cells(row, "D").Comment Is Nothing Then
            wsSource.Cells(row, "D").Comment.Delete
      End If
Else
      With wsSource.Cells(row, "D")

      ' 设置背景颜色为黄色,删除备注，增加备注
         .Interior.Color = RGB(255, 255, 0)
         If Not .Comment Is Nothing Then
            .Comment.Delete
         End If
         .AddComment "需要填写外径壁厚，格式为32*3.4"
      End With

End If

Application.ScreenUpdating = True
End Sub

'给对焊弯头规格赋值
Sub AssignDimensions_J_dhwt(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) & "*" & matches(0).SubMatches(2)
      ElseIf matches.Count > 0 And (InStr(text, "Cr") Or InStr(text, "cr")) Then
         wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "*" & matches(0).SubMatches(2)
      ElseIf matches.Count > 0 Then
         wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "*" & matches(0).SubMatches(2)
      End If
      wsSource.Cells(row, "D").Interior.Color = xlNone
      If Not wsSource.Cells(row, "D").Comment Is Nothing Then
            wsSource.Cells(row, "D").Comment.Delete
      End If
Else
      With wsSource.Cells(row, "D")

      ' 设置背景颜色为黄色,删除备注，增加备注
         .Interior.Color = RGB(255, 255, 0)
         If Not .Comment Is Nothing Then
            .Comment.Delete
         End If
         .AddComment "需要填写外径壁厚，格式为32*3.4"
      End With

End If

Application.ScreenUpdating = True
End Sub

'给承插焊弯头规格赋值
Sub AssignDimensions_J_ccwt(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 matchPatternDN As String
Dim matchPatternCL As String
Dim matchPatternDiameter As String
Dim result As String

Application.ScreenUpdating = False

' 正则表达式模式
matchPatternDN = "DN(\d+)"
matchPatternCL = "CL(\d+)"
matchPatternDiameter = "承插管Φ(\d+(?:\.\d+)?)" ' 调整正则表达式以匹配小数点和小数部分

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

' 匹配DN后面的数字
With regex
      .pattern = matchPatternDN
End With
Set matches = regex.Execute(text)
If matches.Count > 0 Then
      result = result & "DN" & matches(0).SubMatches(0) & ","
End If

' 匹配CL后面的数字
With regex
      .pattern = matchPatternCL
End With
Set matches = regex.Execute(text)
If matches.Count > 0 Then
      result = result & "CL" & matches(0).SubMatches(0) & ","
End If

' 匹配承插管Φ后面的数字
With regex
      .pattern = matchPatternDiameter
End With
Set matches = regex.Execute(text)
If matches.Count > 0 Then
      result = result & "承插管Φ" & matches(0).SubMatches(0) & ","
End If

' 移除最后一个逗号
If Len(result) > 0 Then
      result = Left(result, Len(result) - 1)
End If

' 如果有匹配项，生成指定格式的字符串
If Len(result) > 0 Then
      wsSource.Cells(row, "J").Value = Trim(result) ' 去除前后空格
      wsSource.Cells(row, "D").Interior.Color = xlNone
      If Not wsSource.Cells(row, "D").Comment Is Nothing Then
            wsSource.Cells(row, "D").Comment.Delete
      End If
Else
      With wsSource.Cells(row, "D")

      ' 设置背景颜色为黄色,删除备注，增加备注
         .Interior.Color = RGB(255, 255, 0)
         If Not .Comment Is Nothing Then
            .Comment.Delete
         End If
         .AddComment "需填写，格式如DN15,CL3000,承插管Φ21.3"
      End With


End If

Application.ScreenUpdating = True
End Sub

'给内螺纹弯头规格赋值
Sub AssignDimensions_J_nlwt(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 matchPatternThread As String
Dim result As String

Application.ScreenUpdating = False

' 正则表达式模式
matchPatternThread = "(NPT\(F\)|G\(F\)),DN(\d+),CL(\d{3,})" ' 确保CL后面的数字至少有三位

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

' 匹配螺纹类型、DN和CL后面的数字
With regex
      .pattern = matchPatternThread
End With
Set matches = regex.Execute(text)
If matches.Count > 0 Then
      result = matches(0).Value
End If

' 如果没有匹配到螺纹类型，单独匹配DN和CL
If Len(result) = 0 Then
      ' 由于已经尝试匹配整个模式，这里不再单独匹配DN和CL
End If

' 如果有匹配项，生成指定格式的字符串
If Len(result) > 0 Then
      wsSource.Cells(row, "J").Value = Trim(result) ' 去除前后空格
      wsSource.Cells(row, "D").Interior.Color = xlNone
      If Not wsSource.Cells(row, "D").Comment Is Nothing Then
         wsSource.Cells(row, "D").Comment.Delete
      End If
Else
      With wsSource.Cells(row, "D")
         ' 设置背景颜色为黄色,删除备注，增加备注
         .Interior.Color = RGB(255, 255, 0)
         If Not .Comment Is Nothing Then
            .Comment.Delete
         End If
         .AddComment "需填写，格式如NPT(F),DN40,CL3000或G(F),DN25,CL3000"
      End With
End If

Application.ScreenUpdating = True
End Sub

'给对焊等径三通规格赋值
Sub AssignDimensions_J_dhdjst(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)
      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)
      ElseIf matches.Count > 0 Then
         wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2)
      End If
      wsSource.Cells(row, "D").Interior.Color = xlNone
      If Not wsSource.Cells(row, "D").Comment Is Nothing Then
            wsSource.Cells(row, "D").Comment.Delete
      End If
Else
      With wsSource.Cells(row, "D")

      ' 设置背景颜色为黄色,删除备注，增加备注
         .Interior.Color = RGB(255, 255, 0)
         If Not .Comment Is Nothing Then
            .Comment.Delete
         End If
         .AddComment "需要填写外径壁厚，格式为32*3.4"
      End With

End If

Application.ScreenUpdating = True
End Sub

'给对焊异径三通规格赋值
Sub AssignDimensions_J_dhyjst(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
Dim result As String

Application.ScreenUpdating = False

' 正则表达式模式，匹配形如 "xxx.x[x*]yy.y" 的字符串
matchPattern = "(?:Φ)?(\d+(\.\d+)?)[xX×*](\d+(\.\d+)?)"

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

' 执行正则表达式匹配
Set matches = regex.Execute(text)
If matches.Count > 1 Then
      ' 构建结果字符串
      result = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & "-"
      result = result & "Φ" & matches(1).SubMatches(0) & "x" & matches(1).SubMatches(2)
      ' 如果有匹配项，生成指定格式的字符串
      wsSource.Cells(row, "J").Value = result
      wsSource.Cells(row, "D").Interior.Color = xlNone
      If Not wsSource.Cells(row, "D").Comment Is Nothing Then
         wsSource.Cells(row, "D").Comment.Delete
      End If
Else
      With wsSource.Cells(row, "D")
         ' 设置背景颜色为黄色,删除备注，增加备注
         .Interior.Color = RGB(255, 255, 0)
         If Not .Comment Is Nothing Then
            .Comment.Delete
         End If
         .AddComment "需要填写规格，格式如355x15.09-Φ219.1x10.31"
      End With
End If

Application.ScreenUpdating = True
End Sub

在worksheet1里做了一个文本框TextBook1和一个列表框ListBook1，似乎是调用的时候拒绝调用，看看什么问题，改下代码。

嘉岳呀 · 发表于 2025-1-1 18:29:06

从您提供的代码来看，您在Excel的VBA中创建了一些控件（文本框和列表框），并且希望在特定条件下显示和使用这些控件。我注意到了几个可能的问题点，我们可以逐一检查和修改：

1. **控件名称**：确保您的控件名称在代码中和Excel工作表中是一致的。例如，如果您在工作表中将控件命名为"TextBox1"和"ListBox1"，请确保代码中使用的也是这些名称。

2. **控件类型**：确保您添加到工作表的控件类型是正确的。例如，如果您使用的是ActiveX控件，请确保不是误用了Form控件。

3. **可见性控制**：您的代码中使用了`.Visible = True`和`.Visible = False`来控制控件的显示和隐藏。请确保这些属性被正确地设置。

4. **错误处理**：您的代码中有一些错误处理的部分，但是没有正确地处理可能发生的错误。例如，如果控件不存在，尝试访问它们的属性会引发错误。

5. **控件初始化**：在`Worksheet_SelectionChange`事件中，您需要确保在尝试访问或修改控件属性之前，控件已经被正确地添加到工作表中。

以下是一些修改建议：

- 确保在尝试访问`ws.OLEObjects("TextBox1")`和`ws.OLEObjects("ListBox1")`之前，这些控件已经存在于工作表中。如果控件不存在，您需要先添加它们。

```vba
If Not ws.OLEObjects("TextBox1") Is Nothing Then
ws.OLEObjects("TextBox1").Object.Visible = True
Else
' 添加TextBox1控件的代码
End If

If Not ws.OLEObjects("ListBox1") Is Nothing Then
ws.OLEObjects("ListBox1").Object.Visible = True
Else
' 添加ListBox1控件的代码
End If
```

- 在添加控件的代码中，您需要使用正确的方法来添加ActiveX控件。以下是一个添加文本框和列表框的示例代码：

```vba
Sub AddTextBoxAndListBox()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

' 添加TextBox1
Dim TextBox1 As OLEObject
Set TextBox1 = ws.OLEObjects.Add(ClassType:="Forms.TextBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=100, Top:=100, Width:=100, Height:=20)
TextBox1.Name = "TextBox1"

' 添加ListBox1
Dim ListBox1 As OLEObject
Set ListBox1 = ws.OLEObjects.Add(ClassType:="Forms.ListBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=200, Top:=100, Width:=100, Height:=50)
ListBox1.Name = "ListBox1"
End Sub
```

请确保在尝试使用这些控件之前，先运行上述`AddTextBoxAndListBox`过程来添加控件。希望这些建议能帮助您解决问题。如果还有其他问题，请提供更多的信息，我会尽力帮助您。

账号		自动登录	找回密码
密码			立即注册