写一个vba程序,Windows程序设计,技术交流,鱼C论坛

颂风侯 发表于 2024-12-29 13:34:02

写一个vba程序

考虑写一个excel工作表change的事件
如果行数大于3，当列数为B,C,D,E的单元格内容发生改变时候，
首先清空该行的H,I,J,K的单元格的数据，取消背景色
将变更单元格行的B,C,D,E的单元格的内容合并为一个字符串
对这个字符串进行分析，
分支选择如下
1.如果字符串包含以下字段组合，"无缝","钢管",且不含"锌"或者"zinc"或者"galv",将该单元格所在行的H列单元格赋值为"无缝钢管"，此处是后续判断的基础，作为程序设计标记为"判断1.1"
在"判断1.1"的基础上增加判断，
如果字符串包含"3405",将该单元格所在行的I列单元格赋值为"SH/T3405"；
如果字符串包含"36.10",将该单元格所在行的I列单元格赋值为"ASME B36.10"；
如果字符串包含"36.19",将该单元格所在行的I列单元格赋值为"ASME B36.19"；
如果字符串包含"20553"且含有"a",将该单元格所在行的I列单元格赋值为"HG/T20553(Ⅰa)"；
如果字符串包含"20553"且含有"b",将该单元格所在行的I列单元格赋值为"HG/T20553(Ⅰb)"；
如果字符串包含"20553"且含有"Ⅱ",将该单元格所在行的I列单元格赋值为"HG/T20553(Ⅱ)"；
如果字符串包含"17395"且含有"Ⅰ",将该单元格所在行的I列单元格赋值为"GB/T17395(Ⅰ)"；
如果字符串包含"17395"且含有"Ⅱ",将该单元格所在行的I列单元格赋值为"GB/T17395(Ⅱ)"；
如果字符串包含"17395"且含有"Ⅲ",将该单元格所在行的I列单元格赋值为"GB/T17395(Ⅲ)"；

如果以上都没找到，那么，如果字符串包含"20553",将该单元格所在行的I列单元格设置下拉列表，内容为"HG/T20553(Ⅰa)","HG/T20553(Ⅰb)","HG/T20553(Ⅱ)"三个选项；

在"判断1.1"的基础上增加判断，
如果字符串包含"20"且含有"8163",将该单元格所在行的J列单元格赋值为"20-GB/T8163"；
如果字符串包含"20"且含有"9948",将该单元格所在行的J列单元格赋值为"20-GB/T9948"；
如果字符串包含"20"且含有"3087",将该单元格所在行的J列单元格赋值为"20-GB/T3087"；
如果字符串包含"20"且含有"5310",将该单元格所在行的J列单元格赋值为"20G-GB/T5310"；
如果字符串包含"15Cr"且不含有"9948",将该单元格所在行的J列单元格赋值为"15CrMoG-GB/T5310"；
如果字符串包含"12Cr",将该单元格所在行的J列单元格赋值为"12Cr1MoVG-GB/T5310"；
如果字符串包含"15CrMo"且含有"9948",将该单元格所在行的J列单元格赋值为"15CrMo-GB/T9948"；S30403-GB/T14976
如果字符串包含"30403",将该单元格所在行的J列单元格赋值为"S30403-GB/T14976"；
如果字符串包含"316",将该单元格所在行的J列单元格赋值为"S31603-GB/T14976"；
如果字符串包含"310",将该单元格所在行的J列单元格赋值为"S31008-GB/T14976"；
如果字符串包含"2205",将该单元格所在行的J列单元格赋值为"S22053-GB/T14976"
如果字符串包含"304"且含有"13296",将该单元格所在行的J列单元格赋值为"S30408-GB/T13296"
如果字符串包含"304"且含有"312",将该单元格所在行的J列单元格赋值为"TP304-A312"
如果字符串包含"304且不含有包含"30403",将该单元格所在行的J列单元格赋值为"S30408-GB/T14976"；

在"判断1.1"的基础上增加判断，
如果字符串包含类似于"133x4","133x4.5","45*4.5"这些类型的数据，将该单元格所在行的K列单元格赋值为"Φ？？*？？"数据；

如果字符串包含以下字段组合，"无缝","钢管",且含"锌"或者"zinc"或者"galv",将该单元格所在行的H列单元格赋值为"无缝钢管(镀锌)"

如果sheet1的单元格H到K有变动，到sheet2的B到E列一行行核对是否有完全和当前单元格H到K列内容一致的，如果有，将查找到对应数值的SHEET2的行的第F列的数据返回，填到SHEET1当前行的L列，否则sheet2当前行的L列清空。

要求该代码以VBA写，且重复得用sub，function进行封装简化，保证后续程序重复调用，并且充分得写注释

FishC 发表于 2024-12-29 13:34:34

Private Sub Worksheet_Change(ByVal Target As Range)
' 检查是否在监视的列和行范围内
If Not Intersect(Target, Me.Range("B:E")) Is Nothing Then
   Dim rng As Range
   For Each rng In Intersect(Target, Me.Range("B4:E" & Me.Rows.Count))
         Call ProcessChangedCells(rng)
   Next rng
End If

' 检查sheet1的H到K列的变更
If Not Intersect(Target, Me.Range("H:K")) Is Nothing Then
   If Intersect(Target, Me.Range("H4:K" & Me.Rows.Count)) Is Nothing Then Exit Sub
   For Each rng In Intersect(Target, Me.Range("H:K"))
         Call CheckAndUpdateSheet2(rng)
   Next rng
End If
End Sub

Sub ProcessChangedCells(rng As Range)
Dim rowNum As Long
rowNum = rng.Row

' 清空H, I, J, K列
Me.Range("H" & rowNum & ":K" & rowNum).ClearContents
Me.Range("H" & rowNum & ":K" & rowNum).Interior.ColorIndex = xlNone

Dim combinedStr As String
combinedStr = GetCombinedString(rowNum)

' 分析字符串，设置单元格值
If CheckSeamlessPipe(combinedStr) Then
   Me.Cells(rowNum, "H").Value = "无缝钢管"

   Call SubJudge(combinedStr, rowNum)
   Call SubJudge2(combinedStr, rowNum)
   Call SubJudge3(combinedStr, rowNum)
ElseIf CheckSeamlessPipeWithZinc(combinedStr) Then
   Me.Cells(rowNum, "H").Value = "无缝钢管(镀锌)"
End If
End Sub

Function GetCombinedString(rowNum As Long) As String
Dim combinedStr As String
combinedStr = Join(Application.Transpose(Application.Transpose(Me.Range("B" & rowNum & ":E" & rowNum).Value)), " ")
GetCombinedString = LCase(combinedStr)
End Function

Function CheckSeamlessPipe(combinedStr As String) As Boolean
CheckSeamlessPipe = (InStr(combinedStr, "无缝") > 0 And InStr(combinedStr, "钢管") > 0 _
                     And InStr(combinedStr, "锌") = 0 And InStr(combinedStr, "zinc") = 0 _
                     And InStr(combinedStr, "galv") = 0)
End Function

Function CheckSeamlessPipeWithZinc(combinedStr As String) As Boolean
CheckSeamlessPipeWithZinc = (InStr(combinedStr, "无缝") > 0 And InStr(combinedStr, "钢管") > 0 _
                              And (InStr(combinedStr, "锌") > 0 Or InStr(combinedStr, "zinc") > 0 _
                              Or InStr(combinedStr, "galv") > 0))
End Function

Sub SubJudge(combinedStr As String, rowNum As Long)
' I列判断
If InStr(combinedStr, "3405") > 0 Then
   Me.Cells(rowNum, "I").Value = "SH/T3405"
ElseIf InStr(combinedStr, "36.10") > 0 Then
   Me.Cells(rowNum, "I").Value = "ASME B36.10"
ElseIf InStr(combinedStr, "36.19") > 0 Then
   Me.Cells(rowNum, "I").Value = "ASME B36.19"
ElseIf InStr(combinedStr, "20553") > 0 Then
   If InStr(combinedStr, "a") > 0 Then
         Me.Cells(rowNum, "I").Value = "HG/T20553(Ⅰa)"
   ElseIf InStr(combinedStr, "b") > 0 Then
         Me.Cells(rowNum, "I").Value = "HG/T20553(Ⅰb)"
   ElseIf InStr(combinedStr, "Ⅱ") > 0 Then
         Me.Cells(rowNum, "I").Value = "HG/T20553(Ⅱ)"
   Else
         AddDropDown rowNum, "I", Array("HG/T20553(Ⅰa)", "HG/T20553(Ⅰb)", "HG/T20553(Ⅱ)")
   End If
ElseIf InStr(combinedStr, "17395") > 0 Then
   If InStr(combinedStr, "Ⅰ") > 0 Then
         Me.Cells(rowNum, "I").Value = "GB/T17395(Ⅰ)"
   ElseIf InStr(combinedStr, "Ⅱ") > 0 Then
         Me.Cells(rowNum, "I").Value = "GB/T17395(Ⅱ)"
   ElseIf InStr(combinedStr, "Ⅲ") > 0 Then
         Me.Cells(rowNum, "I").Value = "GB/T17395(Ⅲ)"
   End If
End If
End Sub

Sub SubJudge2(combinedStr As String, rowNum As Long)
' J列判断
If InStr(combinedStr, "20") > 0 Then
   If InStr(combinedStr, "8163") > 0 Then
         Me.Cells(rowNum, "J").Value = "20-GB/T8163"
   ElseIf InStr(combinedStr, "9948") > 0 Then
         Me.Cells(rowNum, "J").Value = "20-GB/T9948"
   ElseIf InStr(combinedStr, "3087") > 0 Then
         Me.Cells(rowNum, "J").Value = "20-GB/T3087"
   ElseIf InStr(combinedStr, "5310") > 0 Then
         Me.Cells(rowNum, "J").Value = "20G-GB/T5310"
   End If
ElseIf InStr(combinedStr, "15Cr") > 0 And InStr(combinedStr, "9948") = 0 Then
   Me.Cells(rowNum, "J").Value = "15CrMoG-GB/T5310"
ElseIf InStr(combinedStr, "12Cr") > 0 Then
   Me.Cells(rowNum, "J").Value = "12Cr1MoVG-GB/T5310"
ElseIf InStr(combinedStr, "15CrMo") > 0 And InStr(combinedStr, "9948") > 0 Then
   Me.Cells(rowNum, "J").Value = "15CrMo-GB/T9948"
ElseIf InStr(combinedStr, "30403") > 0 Then
   Me.Cells(rowNum, "J").Value = "S30403-GB/T14976"
ElseIf InStr(combinedStr, "316") > 0 Then
   Me.Cells(rowNum, "J").Value = "S31603-GB/T14976"
ElseIf InStr(combinedStr, "310") > 0 Then
   Me.Cells(rowNum, "J").Value = "S31008-GB/T14976"
ElseIf InStr(combinedStr, "2205") > 0 Then
   Me.Cells(rowNum, "J").Value = "S22053-GB/T14976"
ElseIf InStr(combinedStr, "304") > 0 Then
   If InStr(combinedStr, "13296") > 0 Then
         Me.Cells(rowNum, "J").Value = "S30408-GB/T13296"
   ElseIf InStr(combinedStr, "312") > 0 Then
         Me.Cells(rowNum, "J").Value = "TP304-A312"
   ElseIf InStr(combinedStr, "30403") = 0 Then
         Me.Cells(rowNum, "J").Value = "S30408-GB/T14976"
   End If
End If
End Sub

Sub SubJudge3(combinedStr As String, rowNum As Long)
' K列判断
Dim result As String
If GetPipeDiameter(combinedStr, result) Then
   Me.Cells(rowNum, "K").Value = result
End If
End Sub

Function GetPipeDiameter(combinedStr As String, ByRef result As String) As Boolean
' 查找示例："133x4","133x4.5","45*4.5"
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = "\d{2,3}[\*xX]\d+\.?\d*"
regEx.IgnoreCase = True
regEx.Global = True

Dim matches As Object
Set matches = regEx.Execute(combinedStr)

If matches.Count > 0 Then
   result = "Φ" & matches(0)
   GetPipeDiameter = True
Else
   GetPipeDiameter = False
End If
End Function

Sub AddDropDown(rowNum As Long, colLetter As String, options As Variant)
With Me.Cells(rowNum, colLetter).Validation
   .Delete
   .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
         xlBetween, Formula1:=Join(options, ",")
   .IgnoreBlank = True
   .InCellDropdown = True
   .InputTitle = ""
   .ErrorTitle = ""
   .InputMessage = ""
   .ErrorMessage = ""
   .ShowInput = True
   .ShowError = True
End With
End Sub

Sub CheckAndUpdateSheet2(rng As Range)
' 校验并更新Sheet2的值
Dim sheet2 As Worksheet
Set sheet2 = ThisWorkbook.Worksheets("Sheet2")

Dim rowNum As Long
rowNum = rng.Row

Dim hToK As String
hToK = Join(Application.Transpose(Application.Transpose(Me.Range("H" & rowNum & ":K" & rowNum).Value)), "|")

Dim found As Boolean
found = False
Dim sh2Row As Long
For sh2Row = 2 To sheet2.Cells(sheet2.Rows.Count, 2).End(xlUp).Row
   If Join(Application.Transpose(Application.Transpose(sheet2.Range("B" & sh2Row & ":E" & sh2Row).Value)), "|") = hToK Then
         Me.Cells(rowNum, "L").Value = sheet2.Cells(sh2Row, "F").Value
         found = True
         Exit For
   End If
Next sh2Row

If Not found Then
   Me.Cells(rowNum, "L").ClearContents
End If
End Sub

以上的VBA代码定义了一个 `Worksheet_Change` 事件处理器，用于处理Excel工作表中的单元格变化。代码中的逻辑根据问题所述的条件对单元格值进行判断、赋值和格式化操作。同时，代码被组织成了多个 `Sub` 和 `Function` 函数来增强可读性和可重用性。本程序会处理 `B` 到 `E` 列范围内的数据修改，和对 `H` 到 `K` 列的变化进行匹配Sheet2中的数据。

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

颂风侯 发表于 2024-12-29 13:42:49

Private Sub Worksheet_Change(ByVal Target As Range)
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 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:F")) 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(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列
For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
   ' 确定变动的单元格是否在最后一行之前
   If KeyCell.row < wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).row Then
         ' 确定查找范围
         LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
         SearchRange = "B" & 2 & ":E" & LastRowDest

         ' 在Sheet2的B到E列查找H,I,J,K列的值' 确认是否应该是"Sheet2"
         ' 在Sheet2的B到E列查找H,I,J,K列的值
         With wsDest.Range(SearchRange)
            On Error Resume Next' 添加错误处理
            Set FoundCell = .Find(What:=KeyCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Err.number <> 0 Then
               Err.Clear
               Set FoundCell = Nothing
            End If
            On Error GoTo 0' 重置错误处理
            If Not FoundCell Is Nothing Then
               wsSource.Cells(KeyCell.row, "L").Value = wsDest.Cells(FoundCell.row, "F").Value
            Else
               wsSource.Cells(KeyCell.row, "L").ClearContents
            End If
         End With

   End If
Next KeyCell
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)
' 根据文本内容，为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
End Sub

Sub AssignMaterials_K_wfgg(ByVal text As String, ByVal row As Long)
' 根据文本内容，为K列材质赋值
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
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

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
End Sub
这段代码报错，帮看下问题怎么改

FishC 发表于 2024-12-29 13:43:03

颂风侯发表于 2024-12-29 13:42
Private Sub Worksheet_Change(ByVal Target As Range ...

以下是这段代码中可能导致错误的地方及其对应的修改建议：

1. **目标监控区域的范围问题**：
If Not Intersect(Target, wsSource.Range("B:F")) Is Nothing Then
这里应该是监视 `B:E` 列，而不是 `B:F`。

**修正建议：**
If Not Intersect(Target, wsSource.Range("B:E")) Is Nothing Then

2. **拦截错误代码修正**：
If Err.number0 Then
应该是使用 `<>` 而不是 ` ` 来表示不等于。

**修正建议：**
If Err.Number <> 0 Then

3. **正则表达式的问题**：
在 `AssignDimensions_J_wfgg` 子程序中，`matchPattern` 中用 `\s*` 表示的可能有额外空格。在 VBA 的正则表达式中可以省略。

**修正建议（可选）：**
matchPattern = "(\d+(\.\d+)?)\s*\s*(\d+(\.\d+)?)"

4. **范围引用中的错误**：
可能出现不匹配与搜索相关范围时的引发错误，确保合并字符串的方式正确：

**修正建议：**
确保 `arrValues` 的合并没有问题，它应该从二维数组转换为一维数组再进行拼接。

text = Join(Application.Transpose(Application.Transpose(arrValues)), "")

5. **增加错误处理的范围**：
确保检查，以及确保 `.Find` 函数的错误处理。

确保这些修改是在调试过程中完成的，可能需要根据具体情况进一步调整程序的其他部分。希望这些建议能帮您解决遇到的问题！如果有其他细节想要分享帮助调试，欢迎继续描述它们。

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

颂风侯 发表于 2024-12-29 14:13:04

Private Sub Worksheet_Change(ByVal Target As Range)
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 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列

For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
   ' 确定变动的单元格是否在最后一行之前
   If KeyCell.row < wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).row Then
         ' 确定查找范围
         LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
         SearchRange = "B" & 2 & ":E" & LastRowDest

         ' 在Sheet2的B到E列查找H,I,J,K列的值' 确认是否应该是"Sheet2"
         ' 在Sheet2的B到E列查找H,I,J,K列的值
         With wsDest.Range(SearchRange)
            On Error Resume Next' 添加错误处理
            Set FoundCell = .Find(What:=KeyCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Err.number <> 0 Then
               Err.Clear
               Set FoundCell = Nothing
            End If
            On Error GoTo 0' 重置错误处理
            If Not FoundCell Is Nothing Then
               wsSource.Cells(KeyCell.row, "L").Value = wsDest.Cells(FoundCell.row, "F").Value
            Else
               wsSource.Cells(KeyCell.row, "L").ClearContents
            End If
         End With

   End If
Next KeyCell

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)
' 根据文本内容，为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
End Sub

Sub AssignMaterials_K_wfgg(ByVal text As String, ByVal row As Long)
' 根据文本内容，为K列材质赋值
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
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

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
End Sub
错误对象424

FishC 发表于 2024-12-29 14:13:16

颂风侯发表于 2024-12-29 14:13
Private Sub Worksheet_Change(ByVal Target As Range ...

对象错误 `424` 通常表示代码中未设置对象或者对象不存在。请检查以下几个可能导致错误的地方：

1. **Worksheet对象设置问题**：确保工作表对象正确设置，并且工作表名称正确。
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")
*确保 `Sheet1` 在工作簿中的确存在，并且拼写正确。*

2. **变量`s`没有正确定义或传递**：在一些代码片段中调用了未定义或传递的`s`变量。务必检查包含与`s`相关的调用。

3. **正则表达式设置问题**：确保正则表达式对象正确实例化。
Set regex = CreateObject("VBScript.RegExp")

4. **Intersect返回Nothing的问题**：`Intersect()`函数可能在`Target`不在给定范围内时返回`Nothing`，此时直接对`Nothing`使用For Each会导致错误。
- **解决方法**：在使用For Each前，确保`Intersect()`返回的不为`Nothing`。
If Not Intersect(Target, wsSource.Range("H:K")) Is Nothing Then
      For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
         ' 执行代码
      Next KeyCell
End If

5. **传递给Sub或Function的参数问题**：确保所有传递的参数都定义正确。

仔细检查以上部分，确保每个对象在使用前都已正确设置，参数在函数中得到正确引用。调试时，通过添加断点逐步检查代码执行情况，发现问题的具体位置以便针对性修正。如果仍有问题，请提供更多的错误线索以便进一步协助。

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

颂风侯 发表于 2024-12-29 14:36:44

Private Sub Worksheet_Change(ByVal Target As Range)
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 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列

If Not Intersect(Target, wsSource.Range("B:K")) Is Nothing Then
   For Each KeyCell In Intersect(Target, wsSource.Range("B:K"))
         ' 确定变动的单元格是否在最后一行之前
         If KeyCell.row < wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).row Then
            ' 确定查找范围
            LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
            SearchRange = "B" & 2 & ":E" & LastRowDest

            ' 在Sheet2的B到E列查找H,I,J,K列的值' 确认是否应该是"Sheet2"
            ' 在Sheet2的B到E列查找H,I,J,K列的值
            With wsDest.Range(SearchRange)
               On Error Resume Next' 添加错误处理
               Set FoundCell = .Find(What:=KeyCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
               If Err.number <> 0 Then
                     Err.Clear
                     Set FoundCell = Nothing
               End If
               On Error GoTo 0' 重置错误处理
               If Not FoundCell Is Nothing Then
                     wsSource.Cells(KeyCell.row, "L").Value = wsDest.Cells(FoundCell.row, "F").Value
               Else
                     wsSource.Cells(KeyCell.row, "L").ClearContents
               End If
            End With

         End If
   Next KeyCell
End If

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)
' 根据文本内容，为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
End Sub

Sub AssignMaterials_K_wfgg(ByVal text As String, ByVal row As Long)
' 根据文本内容，为K列材质赋值
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
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

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
End Sub
这段代码里面的当sheet1的数值和sheet2的行的数值有匹配关系返回值的代码不能执行，帮忙看看问题出在哪里的

FishC 发表于 2024-12-29 14:37:01

颂风侯发表于 2024-12-29 14:36
Private Sub Worksheet_Change(ByVal Target As Range ...

以下是一些可能导致匹配程序不能正常执行的原因及相应的调整建议：

1. **匹配逻辑错误**：
你要确保在 `Sheet2` 中查找所需的值时，值的匹配是基于整个行的数据，而不仅仅是某个单元格。当前代码尝试在 `Sheet2` 的某列查找 `Sheet1` 的某列，而非整行。所以可能需要调整匹配逻辑。

2. **调整匹配范围**：
目前 `SearchRange` 是 `"B2:E" & LastRowDest`，这将搜索 `Sheet2` 的 `B` 到 `E` 列之间。你应该确保这包含了完整的数据范围。

3. **查找逻辑中的错误**：
使用 `.Find()` 时，确保搜索范围和搜索参数是正确
' 通过 transposed string comparison 来比较每个完整行
Dim sourceKey As String
sourceKey = Join(Application.Transpose(Application.Transpose(wsSource.Range("H" & KeyCell.row & ":K" & KeyCell.row).Value)), "|")

For Each r In wsDest.Range(SearchRange).Rows
   If Join(Application.Transpose(Application.Transpose(r.Value)), "|") = sourceKey Then
         wsSource.Cells(KeyCell.row, "L").Value = wsDest.Cells(r.row, "F").Value
         Exit For
   Else
         wsSource.Cells(KeyCell.row, "L").ClearContents
   End If
Next r

4. **错误处理逻辑**：
确保没有额外限制 (如错误拦截) 干扰了正常逻辑

修改后的部分代码如下：
If Not Intersect(Target, wsSource.Range("B:K")) Is Nothing Then
For Each KeyCell In Intersect(Target, wsSource.Range("B:K"))
   If KeyCell.row < wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).row Then
         LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
         SearchRange = "B2:E" & LastRowDest

         Dim sourceKey As String
         sourceKey = Join(Application.Transpose(Application.Transpose(wsSource.Range("H" & KeyCell.row & ":K" & KeyCell.row).Value)), "|")

         Dim r As Range
         For Each r In wsDest.Range(SearchRange).Rows
            If Join(Application.Transpose(Application.Transpose(r.Value)), "|") = sourceKey Then
               wsSource.Cells(KeyCell.row, "L").Value = wsDest.Cells(r.row, "F").Value
               Exit For
            Else
               wsSource.Cells(KeyCell.row, "L").ClearContents
            End If
         Next r
   End If
Next KeyCell
End If

以上调整确保搜索逻辑从整行构造值，通过拼接字符串的方法进行比较，这样保证查找操作是准确的。确保已经测试通过逻辑能正常运行。

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

颂风侯 发表于 2024-12-29 14:58:29

我需要当sheet1的所在单元格的行的第H到K列单元格有发生变动时，进行一次比较取值。
需求如下，当sheet1的单元格H到K的单元格不为空，且发生了改变，这时候将将sheet1的该行的H列单元格去对比sheet2的值，对于sheet2的所有行，依次进行对比
shee1的H列对比sheet2的B列，sheet1的J列对比sheet2的C列，sheet1的K列对比sheet2的D列，sheet1的L列对比sheet2的E列，如果发现完全相同，则
返回sheet2的匹配的这行的第F列数值，填写到sheet1所在行的L列单元格，结束匹配。
如果遍历了sheet2所有行没有找到能完全对应的行，则将sheet1所在行的L列单元格，设为空值

颂风侯 发表于 2024-12-29 15:12:13

Private Sub Worksheet_Change(ByVal Target As Range)
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

' 设置工作表
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列

If Not Intersect(Target, wsSource.Range("B:K")) Is Nothing Then
   For Each KeyCell In Intersect(Target, wsSource.Range("B:K"))
   If KeyCell.row < wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).row Then
   LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
   SearchRange = "B2:E" & LastRowDest

   Dim sourceKey As String
   sourceKey = Join(Application.Transpose(Application.Transpose(wsSource.Range("H" & KeyCell.row & ":K" & KeyCell.row).Value)), "|")

   Dim r As Range
   For Each r In wsDest.Range(SearchRange).Rows
      If Join(Application.Transpose(Application.Transpose(r.Value)), "|") = sourceKey Then
      wsSource.Cells(KeyCell.row, "L").Value = wsDest.Cells(r.row, "F").Value
      Exit For
      Else
      wsSource.Cells(KeyCell.row, "L").ClearContents
      End If
   Next r
   End If
   Next KeyCell
End If

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)
' 根据文本内容，为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
End Sub

Sub AssignMaterials_K_wfgg(ByVal text As String, ByVal row As Long)
' 根据文本内容，为K列材质赋值
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
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

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
End Sub
还是不能从sheet2找到对应的数据返回，帮忙再看看

FishC 发表于 2024-12-29 15:21:43

颂风侯发表于 2024-12-29 14:58
我需要当sheet1的所在单元格的行的第H到K列单元格有发 ...

根据您的需求，以下是调整后的代码，以确保在 `Sheet1` 的 H 到 K 列的单元格发生变化时，对比 `Sheet2` 的相应列并进行匹配：

Private Sub Worksheet_Change(ByVal Target As Range)
' 设置工作表
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")

Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Sheets("Sheet2")

' 检查变动的单元格是否位于H到K列
If Not Intersect(Target, wsSource.Range("H:K")) Is Nothing Then
   Dim KeyCell As Range
   For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
         Dim changedRow As Long
         changedRow = KeyCell.Row

         ' 确保H到K有值
         If Application.CountA(wsSource.Range("H" & changedRow & ":K" & changedRow)) = 4 Then
            Dim FoundMatch As Boolean
            FoundMatch = False

            ' 遍历Sheet2的行
            Dim LastRowDest As Long
            LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row

            Dim r As Long
            For r = 2 To LastRowDest
               If wsSource.Cells(changedRow, "H").Value = wsDest.Cells(r, "B").Value And _
                  wsSource.Cells(changedRow, "J").Value = wsDest.Cells(r, "C").Value And _
                  wsSource.Cells(changedRow, "K").Value = wsDest.Cells(r, "D").Value And _
                  wsSource.Cells(changedRow, "L").Value = wsDest.Cells(r, "E").Value Then
                     ' 找到完全匹配
                     wsSource.Cells(changedRow, "L").Value = wsDest.Cells(r, "F").Value
                     FoundMatch = True
                     Exit For
               End If
            Next r

            ' 如果没有找到匹配
            If Not FoundMatch Then
               wsSource.Cells(changedRow, "L").ClearContents
            End If
         End If
   Next KeyCell
End If
End Sub

在这段代码中：
- 首先检查变动的单元格是否在 H 到 K 列中。
- 当变化发生时，确保 `H` 到 `K` 列中的所有单元格都有值，然后对 `Sheet2` 执行遍历。
- 使用逻辑 `AND` 操作符按行比较 `Sheet1` 的 `H`, `J`, `K`, `L` 列与 `Sheet2` 的 `B`, `C`, `D`, `E` 列来寻找完全匹配。
- 如果找到匹配，将 `Sheet2` 的对应行 `F` 列的值赋予 `Sheet1` 的 `L` 列。
- 如果在 `Sheet2` 没有找到匹配，则清空 `Sheet1` 当前行的 `L` 列单元格。

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

颂风侯 发表于 2024-12-29 15:56:05

Private Sub Worksheet_Change(ByVal Target As Range)
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 15:56:25

颂风侯发表于 2024-12-29 15:56
Private Sub Worksheet_Change(ByVal Target As Range ...

要提高代码的执行速度，可以考虑以下几个改进方法：

1. **限制事件触发范围**：限制 `Worksheet_Change` 事件的触发范围，避免不必要的处理。

2. **减少屏幕更新**：已经使用 `Application.ScreenUpdating` 来减少屏幕更新的次数，这样处理已经非常有效。

3. **用字典结构（Dictionary）来快速查找匹配**：用 `Dictionary` 对 `Sheet2` 的内容进行缓存，减少每次从头到尾的遍历。

以下是针对上述优化策略的改进代码：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim changedRow As Long
Dim KeyCell As Range
Dim i As Long

Application.ScreenUpdating = False
Application.EnableEvents = False

' 设置工作表
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")

Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Sheets("Sheet2")

' 监控范围仅对单元格H到K和B到E
If Not Intersect(Target, wsSource.Range("B:K")) Is Nothing Then
   ' 使用字典来加速查找过程
   Dim dict As Object
   Set dict = CreateObject("Scripting.Dictionary")

   ' 将Sheet2内容缓存到字典中
   Dim LastRow As Long
   LastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row

   For i = 1 To LastRow
         Dim key As String
         key = wsDest.Cells(i, "B").Value & "|" & wsDest.Cells(i, "C").Value & "|" & _
               wsDest.Cells(i, "D").Value & "|" & wsDest.Cells(i, "E").Value
         dict(key) = wsDest.Cells(i, "F").Value
   Next i

   For Each KeyCell In Target
         changedRow = KeyCell.row

         ' 如果行数大于3
         If changedRow > 3 Then
            ' 清相应列
            wsSource.Range("H" & changedRow & ":K" & changedRow).ClearContents
            wsSource.Range("H" & changedRow & ":K" & changedRow).Interior.Color = xlNone

            ' 合并B, C, D, E列内容为一个字符串
            Dim text As String
            text = Join(Application.Transpose(Application.Transpose(wsSource.Range("B" & changedRow & ":E" & changedRow).Value)), "")

            ' 执行条件设置
            If CheckBasicCondition_wfgg(text) Then
               wsSource.Cells(changedRow, "H").Value = "无缝钢管"
               AssignStandards_I_wfgg text, changedRow
               AssignMaterials_K_wfgg text, changedRow
               AssignDimensions_J_wfgg text, changedRow
            ElseIf CheckBasicCondition_dxwfgg(text) Then
               wsSource.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
            End If

            ' 匹配处理
            Dim sourceKey As String
            sourceKey = wsSource.Cells(changedRow, "H").Value & "|" & _
                        wsSource.Cells(changedRow, "I").Value & "|" & _
                        wsSource.Cells(changedRow, "J").Value & "|" & _
                        wsSource.Cells(changedRow, "K").Value

            If dict.exists(sourceKey) Then
               wsSource.Cells(changedRow, "L").Value = dict(sourceKey)
            Else
               wsSource.Cells(changedRow, "L").Value = ""
            End If
         End If
   Next KeyCell
End If

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

' 其他Function和Sub保持不变

使用字典优化查找速度会显著提高，因为它能快速检查某个键值是否存在，而不必每次都遍历Sheet2中的所有行。这可以节省大量时间，特别是当数据量较大时。

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

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

这样跑程序死循环了，看看怎么办呢

页: [1]

鱼C论坛's Archiver

写一个vba程序