[已解决]写一个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 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` 的内容进行缓存，减少每次从头到尾的遍历。

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

1. Option Explicit
   
2. 
   
3. Private Sub Worksheet_Change(ByVal Target As Range)
   
4.     Dim changedRow As Long
   
5.     Dim KeyCell As Range
   
6.     Dim i As Long
   
7. 
   
8.     Application.ScreenUpdating = False
   
9.     Application.EnableEvents = False
   
10. 
    
11.     ' 设置工作表
    
12.     Dim wsSource As Worksheet
    
13.     Set wsSource = ThisWorkbook.Sheets("Sheet1")
    
14.    
    
15.     Dim wsDest As Worksheet
    
16.     Set wsDest = ThisWorkbook.Sheets("Sheet2")
    
17.    
    
18.     ' 监控范围仅对单元格H到K和B到E
    
19.     If Not Intersect(Target, wsSource.Range("B:K")) Is Nothing Then
    
20.         ' 使用字典来加速查找过程
    
21.         Dim dict As Object
    
22.         Set dict = CreateObject("Scripting.Dictionary")
    
23.         
    
24.         ' 将Sheet2内容缓存到字典中
    
25.         Dim LastRow As Long
    
26.         LastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
    
27.         
    
28.         For i = 1 To LastRow
    
29.             Dim key As String
    
30.             key = wsDest.Cells(i, "B").Value & "|" & wsDest.Cells(i, "C").Value & "|" & _
    
31.                   wsDest.Cells(i, "D").Value & "|" & wsDest.Cells(i, "E").Value
    
32.             dict(key) = wsDest.Cells(i, "F").Value
    
33.         Next i
    
34.         
    
35.         For Each KeyCell In Target
    
36.             changedRow = KeyCell.row
    
37. 
    
38.             ' 如果行数大于3
    
39.             If changedRow > 3 Then
    
40.                 ' 清相应列
    
41.                 wsSource.Range("H" & changedRow & ":K" & changedRow).ClearContents
    
42.                 wsSource.Range("H" & changedRow & ":K" & changedRow).Interior.Color = xlNone
    
43.                
    
44.                 ' 合并B, C, D, E列内容为一个字符串
    
45.                 Dim text As String
    
46.                 text = Join(Application.Transpose(Application.Transpose(wsSource.Range("B" & changedRow & ":E" & changedRow).Value)), "")
    
47.                
    
48.                 ' 执行条件设置
    
49.                 If CheckBasicCondition_wfgg(text) Then
    
50.                     wsSource.Cells(changedRow, "H").Value = "无缝钢管"
    
51.                     AssignStandards_I_wfgg text, changedRow
    
52.                     AssignMaterials_K_wfgg text, changedRow
    
53.                     AssignDimensions_J_wfgg text, changedRow
    
54.                 ElseIf CheckBasicCondition_dxwfgg(text) Then
    
55.                     wsSource.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
    
56.                 End If
    
57.                
    
58.                 ' 匹配处理
    
59.                 Dim sourceKey As String
    
60.                 sourceKey = wsSource.Cells(changedRow, "H").Value & "|" & _
    
61.                             wsSource.Cells(changedRow, "I").Value & "|" & _
    
62.                             wsSource.Cells(changedRow, "J").Value & "|" & _
    
63.                             wsSource.Cells(changedRow, "K").Value
    
64.                
    
65.                 If dict.exists(sourceKey) Then
    
66.                     wsSource.Cells(changedRow, "L").Value = dict(sourceKey)
    
67.                 Else
    
68.                     wsSource.Cells(changedRow, "L").Value = ""
    
69.                 End If
    
70.             End If
    
71.         Next KeyCell
    
72.     End If
    
73. 
    
74.     Application.EnableEvents = True
    
75.     Application.ScreenUpdating = True
    
76. End Sub
    
77. 
    
78. ' 其他Function和Sub保持不变

复制代码

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

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

跳转到最佳答案楼层

FishC

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     ' 检查是否在监视的列和行范围内
   
3.     If Not Intersect(Target, Me.Range("B:E")) Is Nothing Then
   
4.         Dim rng As Range
   
5.         For Each rng In Intersect(Target, Me.Range("B4:E" & Me.Rows.Count))
   
6.             Call ProcessChangedCells(rng)
   
7.         Next rng
   
8.     End If
   
9.    
   
10.     ' 检查sheet1的H到K列的变更
    
11.     If Not Intersect(Target, Me.Range("H:K")) Is Nothing Then
    
12.         If Intersect(Target, Me.Range("H4:K" & Me.Rows.Count)) Is Nothing Then Exit Sub
    
13.         For Each rng In Intersect(Target, Me.Range("H:K"))
    
14.             Call CheckAndUpdateSheet2(rng)
    
15.         Next rng
    
16.     End If
    
17. End Sub
    
18. 
    
19. Sub ProcessChangedCells(rng As Range)
    
20.     Dim rowNum As Long
    
21.     rowNum = rng.Row
    
22. 
    
23.     ' 清空H, I, J, K列
    
24.     Me.Range("H" & rowNum & ":K" & rowNum).ClearContents
    
25.     Me.Range("H" & rowNum & ":K" & rowNum).Interior.ColorIndex = xlNone
    
26. 
    
27.     Dim combinedStr As String
    
28.     combinedStr = GetCombinedString(rowNum)
    
29. 
    
30.     ' 分析字符串，设置单元格值
    
31.     If CheckSeamlessPipe(combinedStr) Then
    
32.         Me.Cells(rowNum, "H").Value = "无缝钢管"
    
33. 
    
34.         Call SubJudge(combinedStr, rowNum)
    
35.         Call SubJudge2(combinedStr, rowNum)
    
36.         Call SubJudge3(combinedStr, rowNum)
    
37.     ElseIf CheckSeamlessPipeWithZinc(combinedStr) Then
    
38.         Me.Cells(rowNum, "H").Value = "无缝钢管(镀锌)"
    
39.     End If
    
40. End Sub
    
41. 
    
42. Function GetCombinedString(rowNum As Long) As String
    
43.     Dim combinedStr As String
    
44.     combinedStr = Join(Application.Transpose(Application.Transpose(Me.Range("B" & rowNum & ":E" & rowNum).Value)), " ")
    
45.     GetCombinedString = LCase(combinedStr)
    
46. End Function
    
47. 
    
48. Function CheckSeamlessPipe(combinedStr As String) As Boolean
    
49.     CheckSeamlessPipe = (InStr(combinedStr, "无缝") > 0 And InStr(combinedStr, "钢管") > 0 _
    
50.                          And InStr(combinedStr, "锌") = 0 And InStr(combinedStr, "zinc") = 0 _
    
51.                          And InStr(combinedStr, "galv") = 0)
    
52. End Function
    
53. 
    
54. Function CheckSeamlessPipeWithZinc(combinedStr As String) As Boolean
    
55.     CheckSeamlessPipeWithZinc = (InStr(combinedStr, "无缝") > 0 And InStr(combinedStr, "钢管") > 0 _
    
56.                                  And (InStr(combinedStr, "锌") > 0 Or InStr(combinedStr, "zinc") > 0 _
    
57.                                  Or InStr(combinedStr, "galv") > 0))
    
58. End Function
    
59. 
    
60. Sub SubJudge(combinedStr As String, rowNum As Long)
    
61.     ' I列判断
    
62.     If InStr(combinedStr, "3405") > 0 Then
    
63.         Me.Cells(rowNum, "I").Value = "SH/T3405"
    
64.     ElseIf InStr(combinedStr, "36.10") > 0 Then
    
65.         Me.Cells(rowNum, "I").Value = "ASME B36.10"
    
66.     ElseIf InStr(combinedStr, "36.19") > 0 Then
    
67.         Me.Cells(rowNum, "I").Value = "ASME B36.19"
    
68.     ElseIf InStr(combinedStr, "20553") > 0 Then
    
69.         If InStr(combinedStr, "a") > 0 Then
    
70.             Me.Cells(rowNum, "I").Value = "HG/T20553(Ⅰa)"
    
71.         ElseIf InStr(combinedStr, "b") > 0 Then
    
72.             Me.Cells(rowNum, "I").Value = "HG/T20553(Ⅰb)"
    
73.         ElseIf InStr(combinedStr, "Ⅱ") > 0 Then
    
74.             Me.Cells(rowNum, "I").Value = "HG/T20553(Ⅱ)"
    
75.         Else
    
76.             AddDropDown rowNum, "I", Array("HG/T20553(Ⅰa)", "HG/T20553(Ⅰb)", "HG/T20553(Ⅱ)")
    
77.         End If
    
78.     ElseIf InStr(combinedStr, "17395") > 0 Then
    
79.         If InStr(combinedStr, "Ⅰ") > 0 Then
    
80.             Me.Cells(rowNum, "I").Value = "GB/T17395(Ⅰ)"
    
81.         ElseIf InStr(combinedStr, "Ⅱ") > 0 Then
    
82.             Me.Cells(rowNum, "I").Value = "GB/T17395(Ⅱ)"
    
83.         ElseIf InStr(combinedStr, "Ⅲ") > 0 Then
    
84.             Me.Cells(rowNum, "I").Value = "GB/T17395(Ⅲ)"
    
85.         End If
    
86.     End If
    
87. End Sub
    
88. 
    
89. Sub SubJudge2(combinedStr As String, rowNum As Long)
    
90.     ' J列判断
    
91.     If InStr(combinedStr, "20") > 0 Then
    
92.         If InStr(combinedStr, "8163") > 0 Then
    
93.             Me.Cells(rowNum, "J").Value = "20-GB/T8163"
    
94.         ElseIf InStr(combinedStr, "9948") > 0 Then
    
95.             Me.Cells(rowNum, "J").Value = "20-GB/T9948"
    
96.         ElseIf InStr(combinedStr, "3087") > 0 Then
    
97.             Me.Cells(rowNum, "J").Value = "20-GB/T3087"
    
98.         ElseIf InStr(combinedStr, "5310") > 0 Then
    
99.             Me.Cells(rowNum, "J").Value = "20G-GB/T5310"
    
100.         End If
     
101.     ElseIf InStr(combinedStr, "15Cr") > 0 And InStr(combinedStr, "9948") = 0 Then
     
102.         Me.Cells(rowNum, "J").Value = "15CrMoG-GB/T5310"
     
103.     ElseIf InStr(combinedStr, "12Cr") > 0 Then
     
104.         Me.Cells(rowNum, "J").Value = "12Cr1MoVG-GB/T5310"
     
105.     ElseIf InStr(combinedStr, "15CrMo") > 0 And InStr(combinedStr, "9948") > 0 Then
     
106.         Me.Cells(rowNum, "J").Value = "15CrMo-GB/T9948"
     
107.     ElseIf InStr(combinedStr, "30403") > 0 Then
     
108.         Me.Cells(rowNum, "J").Value = "S30403-GB/T14976"
     
109.     ElseIf InStr(combinedStr, "316") > 0 Then
     
110.         Me.Cells(rowNum, "J").Value = "S31603-GB/T14976"
     
111.     ElseIf InStr(combinedStr, "310") > 0 Then
     
112.         Me.Cells(rowNum, "J").Value = "S31008-GB/T14976"
     
113.     ElseIf InStr(combinedStr, "2205") > 0 Then
     
114.         Me.Cells(rowNum, "J").Value = "S22053-GB/T14976"
     
115.     ElseIf InStr(combinedStr, "304") > 0 Then
     
116.         If InStr(combinedStr, "13296") > 0 Then
     
117.             Me.Cells(rowNum, "J").Value = "S30408-GB/T13296"
     
118.         ElseIf InStr(combinedStr, "312") > 0 Then
     
119.             Me.Cells(rowNum, "J").Value = "TP304-A312"
     
120.         ElseIf InStr(combinedStr, "30403") = 0 Then
     
121.             Me.Cells(rowNum, "J").Value = "S30408-GB/T14976"
     
122.         End If
     
123.     End If
     
124. End Sub
     
125. 
     
126. Sub SubJudge3(combinedStr As String, rowNum As Long)
     
127.     ' K列判断
     
128.     Dim result As String
     
129.     If GetPipeDiameter(combinedStr, result) Then
     
130.         Me.Cells(rowNum, "K").Value = result
     
131.     End If
     
132. End Sub
     
133. 
     
134. Function GetPipeDiameter(combinedStr As String, ByRef result As String) As Boolean
     
135.     ' 查找示例："133x4","133x4.5","45*4.5"
     
136.     Dim regEx As Object
     
137.     Set regEx = CreateObject("VBScript.RegExp")
     
138.     regEx.Pattern = "\d{2,3}[\*xX]\d+\.?\d*"
     
139.     regEx.IgnoreCase = True
     
140.     regEx.Global = True
     
141. 
     
142.     Dim matches As Object
     
143.     Set matches = regEx.Execute(combinedStr)
     
144. 
     
145.     If matches.Count > 0 Then
     
146.         result = "Φ" & matches(0)
     
147.         GetPipeDiameter = True
     
148.     Else
     
149.         GetPipeDiameter = False
     
150.     End If
     
151. End Function
     
152. 
     
153. Sub AddDropDown(rowNum As Long, colLetter As String, options As Variant)
     
154.     With Me.Cells(rowNum, colLetter).Validation
     
155.         .Delete
     
156.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
     
157.              xlBetween, Formula1:=Join(options, ",")
     
158.         .IgnoreBlank = True
     
159.         .InCellDropdown = True
     
160.         .InputTitle = ""
     
161.         .ErrorTitle = ""
     
162.         .InputMessage = ""
     
163.         .ErrorMessage = ""
     
164.         .ShowInput = True
     
165.         .ShowError = True
     
166.     End With
     
167. End Sub
     
168. 
     
169. Sub CheckAndUpdateSheet2(rng As Range)
     
170.     ' 校验并更新Sheet2的值
     
171.     Dim sheet2 As Worksheet
     
172.     Set sheet2 = ThisWorkbook.Worksheets("Sheet2")
     
173.    
     
174.     Dim rowNum As Long
     
175.     rowNum = rng.Row
     
176. 
     
177.     Dim hToK As String
     
178.     hToK = Join(Application.Transpose(Application.Transpose(Me.Range("H" & rowNum & ":K" & rowNum).Value)), "|")
     
179. 
     
180.     Dim found As Boolean
     
181.     found = False
     
182.     Dim sh2Row As Long
     
183.     For sh2Row = 2 To sheet2.Cells(sheet2.Rows.Count, 2).End(xlUp).Row
     
184.         If Join(Application.Transpose(Application.Transpose(sheet2.Range("B" & sh2Row & ":E" & sh2Row).Value)), "|") = hToK Then
     
185.             Me.Cells(rowNum, "L").Value = sheet2.Cells(sh2Row, "F").Value
     
186.             found = True
     
187.             Exit For
     
188.         End If
     
189.     Next sh2Row
     
190. 
     
191.     If Not found Then
     
192.         Me.Cells(rowNum, "L").ClearContents
     
193.     End If
     
194. End Sub

复制代码

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

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

颂风侯

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*[xX×*]\s*(\d+(\.\d+)?)"

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

    ' 执行正则表达式匹配
    If regex.Test(text) Then
        Set matches = regex.Execute(text)
        ' 如果有匹配项，生成指定格式的字符串
        If matches.Count > 0 And (InStr(text, "3087") Or InStr(text, "5310")) And InStr(text, "20") Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火,NB/T47019"
         ElseIf matches.Count > 0 And (InStr(text, "Cr") Or InStr(text, "cr")) Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火+回火,NB/T47019"
         ElseIf matches.Count > 0 Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2)
        End If
    Else
        With wsSource.Cells(row, "J")
             .Value = "请在前面写入正确规格,形式如88.9x5.6"
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
        End With
        
    End If
End Sub
这段代码报错，帮看下问题怎么改

FishC

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

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

1. **目标监控区域的范围问题**：
  

1. If Not Intersect(Target, wsSource.Range("B:F")) Is Nothing Then

复制代码

   这里应该是监视 `B:E` 列，而不是 `B:F`。

   **修正建议：**
  

1. If Not Intersect(Target, wsSource.Range("B:E")) Is Nothing Then

复制代码

2. **拦截错误代码修正**：
  

1. If Err.number  0 Then

复制代码

   应该是使用 `<>` 而不是 ` ` 来表示不等于。

   **修正建议：**
  

1. If Err.Number <> 0 Then

复制代码

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

   **修正建议（可选）：**
  

1. matchPattern = "(\d+(\.\d+)?)\s*\s*(\d+(\.\d+)?)"

复制代码

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

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

  

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

复制代码

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

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

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

颂风侯

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

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

1. **Worksheet对象设置问题**：确保工作表对象正确设置，并且工作表名称正确。
  

1. Dim wsSource As Worksheet
   
2.    Set wsSource = ThisWorkbook.Sheets("Sheet1")

复制代码

   *确保 `Sheet1` 在工作簿中的确存在，并且拼写正确。*

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

3. **正则表达式设置问题**：确保正则表达式对象正确实例化。
  

1. Set regex = CreateObject("VBScript.RegExp")

复制代码

4. **Intersect返回Nothing的问题**：`Intersect()`函数可能在`Target`不在给定范围内时返回`Nothing`，此时直接对`Nothing`使用For Each会导致错误。
   - **解决方法**：在使用For Each前，确保`Intersect()`返回的不为`Nothing`。
   

1. If Not Intersect(Target, wsSource.Range("H:K")) Is Nothing Then
   
2.          For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
   
3.              ' 执行代码
   
4.          Next KeyCell
   
5.      End If

复制代码

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

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

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

颂风侯

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*[xX×*]\s*(\d+(\.\d+)?)"

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

    ' 执行正则表达式匹配
    If regex.Test(text) Then
        Set matches = regex.Execute(text)
        ' 如果有匹配项，生成指定格式的字符串
        If matches.Count > 0 And (InStr(text, "3087") Or InStr(text, "5310")) And InStr(text, "20") Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火,NB/T47019"
         ElseIf matches.Count > 0 And (InStr(text, "Cr") Or InStr(text, "cr")) Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火+回火,NB/T47019"
         ElseIf matches.Count > 0 Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2)
        End If
    Else
        With wsSource.Cells(row, "J")
             .Value = "请在前面写入正确规格,形式如88.9x5.6"
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
        End With
        
    End If
End Sub
这段代码里面的当sheet1的数值和sheet2的行的数值有匹配关系返回值的代码不能执行，帮忙看看问题出在哪里的

FishC

颂风侯 发表于 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()` 时，确保搜索范围和搜索参数是正确
  

1. ' 通过 transposed string comparison 来比较每个完整行
   
2.    Dim sourceKey As String
   
3.    sourceKey = Join(Application.Transpose(Application.Transpose(wsSource.Range("H" & KeyCell.row & ":K" & KeyCell.row).Value)), "|")
   
4. 
   
5.    For Each r In wsDest.Range(SearchRange).Rows
   
6.         If Join(Application.Transpose(Application.Transpose(r.Value)), "|") = sourceKey Then
   
7.             wsSource.Cells(KeyCell.row, "L").Value = wsDest.Cells(r.row, "F").Value
   
8.             Exit For
   
9.         Else
   
10.             wsSource.Cells(KeyCell.row, "L").ClearContents
    
11.         End If
    
12.    Next r

复制代码

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

修改后的部分代码如下：

1. If Not Intersect(Target, wsSource.Range("B:K")) Is Nothing Then
   
2.     For Each KeyCell In Intersect(Target, wsSource.Range("B:K"))
   
3.         If KeyCell.row < wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).row Then
   
4.             LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
   
5.             SearchRange = "B2:E" & LastRowDest
   
6. 
   
7.             Dim sourceKey As String
   
8.             sourceKey = Join(Application.Transpose(Application.Transpose(wsSource.Range("H" & KeyCell.row & ":K" & KeyCell.row).Value)), "|")
   
9. 
   
10.             Dim r As Range
    
11.             For Each r In wsDest.Range(SearchRange).Rows
    
12.                 If Join(Application.Transpose(Application.Transpose(r.Value)), "|") = sourceKey Then
    
13.                     wsSource.Cells(KeyCell.row, "L").Value = wsDest.Cells(r.row, "F").Value
    
14.                     Exit For
    
15.                 Else
    
16.                     wsSource.Cells(KeyCell.row, "L").ClearContents
    
17.                 End If
    
18.             Next r
    
19.         End If
    
20.     Next KeyCell
    
21. End If

复制代码

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

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

颂风侯

我需要当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列单元格，设为空值

颂风侯

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*[xX×*]\s*(\d+(\.\d+)?)"

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

    ' 执行正则表达式匹配
    If regex.Test(text) Then
        Set matches = regex.Execute(text)
        ' 如果有匹配项，生成指定格式的字符串
        If matches.Count > 0 And (InStr(text, "3087") Or InStr(text, "5310")) And InStr(text, "20") Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火,NB/T47019"
         ElseIf matches.Count > 0 And (InStr(text, "Cr") Or InStr(text, "cr")) Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火+回火,NB/T47019"
         ElseIf matches.Count > 0 Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2)
        End If
    Else
        With wsSource.Cells(row, "J")
             .Value = "请在前面写入正确规格,形式如88.9x5.6"
        ' 设置背景颜色为黄色
             .Interior.Color = RGB(255, 255, 0)
        End With
        
    End If
End Sub
还是不能从sheet2找到对应的数据返回，帮忙再看看

FishC

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

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

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     ' 设置工作表
   
3.     Dim wsSource As Worksheet
   
4.     Set wsSource = ThisWorkbook.Sheets("Sheet1")
   
5. 
   
6.     Dim wsDest As Worksheet
   
7.     Set wsDest = ThisWorkbook.Sheets("Sheet2")
   
8. 
   
9.     ' 检查变动的单元格是否位于H到K列
   
10.     If Not Intersect(Target, wsSource.Range("H:K")) Is Nothing Then
    
11.         Dim KeyCell As Range
    
12.         For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
    
13.             Dim changedRow As Long
    
14.             changedRow = KeyCell.Row
    
15. 
    
16.             ' 确保H到K有值
    
17.             If Application.CountA(wsSource.Range("H" & changedRow & ":K" & changedRow)) = 4 Then
    
18.                 Dim FoundMatch As Boolean
    
19.                 FoundMatch = False
    
20. 
    
21.                 ' 遍历Sheet2的行
    
22.                 Dim LastRowDest As Long
    
23.                 LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row
    
24. 
    
25.                 Dim r As Long
    
26.                 For r = 2 To LastRowDest
    
27.                     If wsSource.Cells(changedRow, "H").Value = wsDest.Cells(r, "B").Value And _
    
28.                        wsSource.Cells(changedRow, "J").Value = wsDest.Cells(r, "C").Value And _
    
29.                        wsSource.Cells(changedRow, "K").Value = wsDest.Cells(r, "D").Value And _
    
30.                        wsSource.Cells(changedRow, "L").Value = wsDest.Cells(r, "E").Value Then
    
31.                         ' 找到完全匹配
    
32.                         wsSource.Cells(changedRow, "L").Value = wsDest.Cells(r, "F").Value
    
33.                         FoundMatch = True
    
34.                         Exit For
    
35.                     End If
    
36.                 Next r
    
37. 
    
38.                 ' 如果没有找到匹配
    
39.                 If Not FoundMatch Then
    
40.                     wsSource.Cells(changedRow, "L").ClearContents
    
41.                 End If
    
42.             End If
    
43.         Next KeyCell
    
44.     End If
    
45. 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 小助理，如未能正确解答您的问题，请继续追问。

颂风侯

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*[xX×*]\s*(\d+(\.\d+)?)"

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

    ' 执行正则表达式匹配
    If regex.Test(text) Then
        Set matches = regex.Execute(text)
        ' 如果有匹配项，生成指定格式的字符串
        If matches.Count > 0 And (InStr(text, "3087") Or InStr(text, "5310")) And InStr(text, "20") Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火,NB/T47019"
         ElseIf matches.Count > 0 And (InStr(text, "Cr") Or InStr(text, "cr")) Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2) & ",正火+回火,NB/T47019"
         ElseIf matches.Count > 0 Then
            wsSource.Cells(row, "J").Value = "Φ" & matches(0).SubMatches(0) & "x" & matches(0).SubMatches(2)
        End If
    Else
        With wsSource.Cells(row, "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
Private Sub Worksheet_Change(ByVal Target As Range ...

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

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

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

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

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

1. Option Explicit
   
2. 
   
3. Private Sub Worksheet_Change(ByVal Target As Range)
   
4.     Dim changedRow As Long
   
5.     Dim KeyCell As Range
   
6.     Dim i As Long
   
7. 
   
8.     Application.ScreenUpdating = False
   
9.     Application.EnableEvents = False
   
10. 
    
11.     ' 设置工作表
    
12.     Dim wsSource As Worksheet
    
13.     Set wsSource = ThisWorkbook.Sheets("Sheet1")
    
14.    
    
15.     Dim wsDest As Worksheet
    
16.     Set wsDest = ThisWorkbook.Sheets("Sheet2")
    
17.    
    
18.     ' 监控范围仅对单元格H到K和B到E
    
19.     If Not Intersect(Target, wsSource.Range("B:K")) Is Nothing Then
    
20.         ' 使用字典来加速查找过程
    
21.         Dim dict As Object
    
22.         Set dict = CreateObject("Scripting.Dictionary")
    
23.         
    
24.         ' 将Sheet2内容缓存到字典中
    
25.         Dim LastRow As Long
    
26.         LastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
    
27.         
    
28.         For i = 1 To LastRow
    
29.             Dim key As String
    
30.             key = wsDest.Cells(i, "B").Value & "|" & wsDest.Cells(i, "C").Value & "|" & _
    
31.                   wsDest.Cells(i, "D").Value & "|" & wsDest.Cells(i, "E").Value
    
32.             dict(key) = wsDest.Cells(i, "F").Value
    
33.         Next i
    
34.         
    
35.         For Each KeyCell In Target
    
36.             changedRow = KeyCell.row
    
37. 
    
38.             ' 如果行数大于3
    
39.             If changedRow > 3 Then
    
40.                 ' 清相应列
    
41.                 wsSource.Range("H" & changedRow & ":K" & changedRow).ClearContents
    
42.                 wsSource.Range("H" & changedRow & ":K" & changedRow).Interior.Color = xlNone
    
43.                
    
44.                 ' 合并B, C, D, E列内容为一个字符串
    
45.                 Dim text As String
    
46.                 text = Join(Application.Transpose(Application.Transpose(wsSource.Range("B" & changedRow & ":E" & changedRow).Value)), "")
    
47.                
    
48.                 ' 执行条件设置
    
49.                 If CheckBasicCondition_wfgg(text) Then
    
50.                     wsSource.Cells(changedRow, "H").Value = "无缝钢管"
    
51.                     AssignStandards_I_wfgg text, changedRow
    
52.                     AssignMaterials_K_wfgg text, changedRow
    
53.                     AssignDimensions_J_wfgg text, changedRow
    
54.                 ElseIf CheckBasicCondition_dxwfgg(text) Then
    
55.                     wsSource.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
    
56.                 End If
    
57.                
    
58.                 ' 匹配处理
    
59.                 Dim sourceKey As String
    
60.                 sourceKey = wsSource.Cells(changedRow, "H").Value & "|" & _
    
61.                             wsSource.Cells(changedRow, "I").Value & "|" & _
    
62.                             wsSource.Cells(changedRow, "J").Value & "|" & _
    
63.                             wsSource.Cells(changedRow, "K").Value
    
64.                
    
65.                 If dict.exists(sourceKey) Then
    
66.                     wsSource.Cells(changedRow, "L").Value = dict(sourceKey)
    
67.                 Else
    
68.                     wsSource.Cells(changedRow, "L").Value = ""
    
69.                 End If
    
70.             End If
    
71.         Next KeyCell
    
72.     End If
    
73. 
    
74.     Application.EnableEvents = True
    
75.     Application.ScreenUpdating = True
    
76. End Sub
    
77. 
    
78. ' 其他Function和Sub保持不变

复制代码

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

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

颂风侯

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