设为首页收藏本站
切换到窄版

鱼C论坛

 找回密码
 立即注册
鱼C论坛»论坛 › 编程语言专区 › Windows程序设计 › 求助一个vba
返回列表 发新帖
查看: 349|回复: 11

[已解决]求助一个vba

[复制链接]
颂风侯
发表于 2024-12-27 16:02:30 | 显示全部楼层 |阅读模式

马上注册，结交更多好友，享用更多功能^_^

您需要 登录 才可以下载或查看，没有账号？立即注册

x
考虑写一个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(Ⅲ)"；
在"判断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"；

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

要求该代码以VBA写，且重复得用sub，function进行封装简化，保证后续程序重复调用，并且充分得写注释
最佳答案
月排行榜 / 总排行榜
FishC
2024-12-27 16:02:58
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim changedRow As Long
  3.     Dim text As String

  5.     ' 监控范围：B, C, D, E 列
  6.     If Not Intersect(Target, Me.Range("B:E")) Is Nothing Then
  7.         changedRow = Target.Row

  9.         ' 如果行数大于3
  10.         If changedRow > 3 Then
  11.             ' 清空该行的H, I, J, K单元格的数据
  12.             Me.Range("H" & changedRow & ":K" & changedRow).ClearContents

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

  17.             ' 第一个判断：无缝钢管且不含锌
  18.             If CheckBasicCondition(text, False) Then
  19.                 Me.Cells(changedRow, "H").Value = "无缝钢管"
  20.                 ' 后续条件分析并赋值I, J列
  21.                 AssignStandards_I text, changedRow
  22.                 AssignMaterials_J text, changedRow
  23.             End If

  25.             ' 第二个判断：无缝钢管且含锌
  26.             If CheckBasicCondition(text, True) Then
  27.                 Me.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
  28.             End If
  29.         End If
  30.     End If
  31. End Sub

  33. Function CheckBasicCondition(ByVal text As String, ByVal containsZinc As Boolean) As Boolean
  34.     If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 Then
  35.         If containsZinc Then
  36.             CheckBasicCondition = (InStr(text, "锌") > 0 Or InStr(text, "zinc") > 0 Or InStr(text, "galv") > 0)
  37.         Else
  38.             CheckBasicCondition = (InStr(text, "锌") = 0 And InStr(text, "zinc") = 0 And InStr(text, "galv") = 0)
  39.         End If
  40.     Else
  41.         CheckBasicCondition = False
  42.     End If
  43. End Function

  45. Sub AssignStandards_I(ByVal text As String, ByVal row As Long)
  46.     Select Case True
  47.         Case InStr(text, "3405") > 0
  48.             Cells(row, "I").Value = "SH/T3405"
  49.         Case InStr(text, "36.10") > 0
  50.             Cells(row, "I").Value = "ASME B36.10"
  51.         Case InStr(text, "36.19") > 0
  52.             Cells(row, "I").Value = "ASME B36.19"
  53.         Case InStr(text, "20553") > 0
  54.             If InStr(text, "a") > 0 Then
  55.                 Cells(row, "I").Value = "HG/T20553(Ⅰa)"
  56.             ElseIf InStr(text, "b") > 0 Then
  57.                 Cells(row, "I").Value = "HG/T20553(Ⅰb)"
  58.             ElseIf InStr(text, "Ⅱ") > 0 Then
  59.                 Cells(row, "I").Value = "HG/T20553(Ⅱ)"
  60.             End If
  61.         Case InStr(text, "17395") > 0
  62.             If InStr(text, "Ⅰ") > 0 Then
  63.                 Cells(row, "I").Value = "GB/T17395(Ⅰ)"
  64.             ElseIf InStr(text, "Ⅱ") > 0 Then
  65.                 Cells(row, "I").Value = "GB/T17395(Ⅱ)"
  66.             ElseIf InStr(text, "Ⅲ") > 0 Then
  67.                 Cells(row, "I").Value = "GB/T17395(Ⅲ)"
  68.             End If
  69.     End Select
  70. End Sub

  72. Sub AssignMaterials_J(ByVal text As String, ByVal row As Long)
  73.     Select Case True
  74.         Case InStr(text, "20") > 0 And InStr(text, "8163") > 0
  75.             Cells(row, "J").Value = "20-GB/T8163"
  76.         Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
  77.             Cells(row, "J").Value = "20-GB/T9948"
  78.         Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
  79.             Cells(row, "J").Value = "20-GB/T3087"
  80.         Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
  81.             Cells(row, "J").Value = "20G-GB/T5310"
  82.         Case InStr(text, "15Cr") > 0 And InStr(text, "9948") = 0
  83.             Cells(row, "J").Value = "15CrMoG-GB/T5310"
  84.         Case InStr(text, "12Cr") > 0
  85.             Cells(row, "J").Value = "12Cr1MoVG-GB/T5310"
  86.         Case InStr(text, "15CrMo") > 0 And InStr(text, "9948") > 0
  87.             Cells(row, "J").Value = "15CrMo-GB/T9948"
  88.         Case InStr(text, "30403") > 0
  89.             Cells(row, "J").Value = "S30403-GB/T14976"
  90.         Case InStr(text, "316") > 0
  91.             Cells(row, "J").Value = "S31603-GB/T14976"
  92.         Case InStr(text, "310") > 0
  93.             Cells(row, "J").Value = "S31008-GB/T14976"
  94.         Case InStr(text, "2205") > 0
  95.             Cells(row, "J").Value = "S22053-GB/T14976"
  96.         Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
  97.             Cells(row, "J").Value = "S30408-GB/T13296"
  98.         Case InStr(text, "304") > 0 And InStr(text, "312") > 0
  99.             Cells(row, "J").Value = "TP304-A312"
  100.         Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
  101.             Cells(row, "J").Value = "S30408-GB/T14976"
  102.     End Select
  103. End Sub
复制代码


以上的VBA代码通过Worksheet_Change事件实现了所需的功能。代码将事件处理程序封装在各自的Sub和Function中，便于重复调用和简化代码结构。注释和函数命名提供了逻辑的清晰划分，可以帮助理解和维护代码。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。
小甲鱼最新课程 -> https://ilovefishc.com
回复

使用道具 举报

FishC
发表于 2024-12-27 16:02:58 | 显示全部楼层    本楼为最佳答案   
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim changedRow As Long
  3.     Dim text As String

  5.     ' 监控范围：B, C, D, E 列
  6.     If Not Intersect(Target, Me.Range("B:E")) Is Nothing Then
  7.         changedRow = Target.Row

  9.         ' 如果行数大于3
  10.         If changedRow > 3 Then
  11.             ' 清空该行的H, I, J, K单元格的数据
  12.             Me.Range("H" & changedRow & ":K" & changedRow).ClearContents

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

  17.             ' 第一个判断：无缝钢管且不含锌
  18.             If CheckBasicCondition(text, False) Then
  19.                 Me.Cells(changedRow, "H").Value = "无缝钢管"
  20.                 ' 后续条件分析并赋值I, J列
  21.                 AssignStandards_I text, changedRow
  22.                 AssignMaterials_J text, changedRow
  23.             End If

  25.             ' 第二个判断：无缝钢管且含锌
  26.             If CheckBasicCondition(text, True) Then
  27.                 Me.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
  28.             End If
  29.         End If
  30.     End If
  31. End Sub

  33. Function CheckBasicCondition(ByVal text As String, ByVal containsZinc As Boolean) As Boolean
  34.     If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 Then
  35.         If containsZinc Then
  36.             CheckBasicCondition = (InStr(text, "锌") > 0 Or InStr(text, "zinc") > 0 Or InStr(text, "galv") > 0)
  37.         Else
  38.             CheckBasicCondition = (InStr(text, "锌") = 0 And InStr(text, "zinc") = 0 And InStr(text, "galv") = 0)
  39.         End If
  40.     Else
  41.         CheckBasicCondition = False
  42.     End If
  43. End Function

  45. Sub AssignStandards_I(ByVal text As String, ByVal row As Long)
  46.     Select Case True
  47.         Case InStr(text, "3405") > 0
  48.             Cells(row, "I").Value = "SH/T3405"
  49.         Case InStr(text, "36.10") > 0
  50.             Cells(row, "I").Value = "ASME B36.10"
  51.         Case InStr(text, "36.19") > 0
  52.             Cells(row, "I").Value = "ASME B36.19"
  53.         Case InStr(text, "20553") > 0
  54.             If InStr(text, "a") > 0 Then
  55.                 Cells(row, "I").Value = "HG/T20553(Ⅰa)"
  56.             ElseIf InStr(text, "b") > 0 Then
  57.                 Cells(row, "I").Value = "HG/T20553(Ⅰb)"
  58.             ElseIf InStr(text, "Ⅱ") > 0 Then
  59.                 Cells(row, "I").Value = "HG/T20553(Ⅱ)"
  60.             End If
  61.         Case InStr(text, "17395") > 0
  62.             If InStr(text, "Ⅰ") > 0 Then
  63.                 Cells(row, "I").Value = "GB/T17395(Ⅰ)"
  64.             ElseIf InStr(text, "Ⅱ") > 0 Then
  65.                 Cells(row, "I").Value = "GB/T17395(Ⅱ)"
  66.             ElseIf InStr(text, "Ⅲ") > 0 Then
  67.                 Cells(row, "I").Value = "GB/T17395(Ⅲ)"
  68.             End If
  69.     End Select
  70. End Sub

  72. Sub AssignMaterials_J(ByVal text As String, ByVal row As Long)
  73.     Select Case True
  74.         Case InStr(text, "20") > 0 And InStr(text, "8163") > 0
  75.             Cells(row, "J").Value = "20-GB/T8163"
  76.         Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
  77.             Cells(row, "J").Value = "20-GB/T9948"
  78.         Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
  79.             Cells(row, "J").Value = "20-GB/T3087"
  80.         Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
  81.             Cells(row, "J").Value = "20G-GB/T5310"
  82.         Case InStr(text, "15Cr") > 0 And InStr(text, "9948") = 0
  83.             Cells(row, "J").Value = "15CrMoG-GB/T5310"
  84.         Case InStr(text, "12Cr") > 0
  85.             Cells(row, "J").Value = "12Cr1MoVG-GB/T5310"
  86.         Case InStr(text, "15CrMo") > 0 And InStr(text, "9948") > 0
  87.             Cells(row, "J").Value = "15CrMo-GB/T9948"
  88.         Case InStr(text, "30403") > 0
  89.             Cells(row, "J").Value = "S30403-GB/T14976"
  90.         Case InStr(text, "316") > 0
  91.             Cells(row, "J").Value = "S31603-GB/T14976"
  92.         Case InStr(text, "310") > 0
  93.             Cells(row, "J").Value = "S31008-GB/T14976"
  94.         Case InStr(text, "2205") > 0
  95.             Cells(row, "J").Value = "S22053-GB/T14976"
  96.         Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
  97.             Cells(row, "J").Value = "S30408-GB/T13296"
  98.         Case InStr(text, "304") > 0 And InStr(text, "312") > 0
  99.             Cells(row, "J").Value = "TP304-A312"
  100.         Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
  101.             Cells(row, "J").Value = "S30408-GB/T14976"
  102.     End Select
  103. End Sub
复制代码


以上的VBA代码通过Worksheet_Change事件实现了所需的功能。代码将事件处理程序封装在各自的Sub和Function中，便于重复调用和简化代码结构。注释和函数命名提供了逻辑的清晰划分，可以帮助理解和维护代码。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

颂风侯
 楼主| 发表于 2024-12-27 16:20:56 | 显示全部楼层
考虑写一个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(Ⅲ)"；
在"判断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列单元格赋值为"无缝钢管(镀锌)"

要求该代码以VBA写，且重复得用sub，function进行封装简化，保证后续程序重复调用，并且充分得写注释
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

FishC
发表于 2024-12-27 16:21:52 | 显示全部楼层
颂风侯 发表于 2024-12-27 16:20
考虑写一个excel工作表change的事件
如果行数大于3， ...

  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim changedRow As Long
  3.     Dim text As String

  5.     ' 监控范围：B, C, D, E 列
  6.     If Not Intersect(Target, Me.Range("B:E")) Is Nothing Then
  7.         changedRow = Target.Row

  9.         ' 如果行数大于3
  10.         If changedRow > 3 Then
  11.             ' 清空该行的H, I, J, K单元格的数据
  12.             Me.Range("H" & changedRow & ":K" & changedRow).ClearContents
  13.             
  14.             ' 合并B, C, D, E列内容为一个字符串
  15.             text = Join(Application.Transpose(Application.Transpose(Me.Range("B" & changedRow & ":E" & changedRow).Value)), "")
  16.             
  17.             ' 第一分支选择逻辑
  18.             Call BasicConditionCheck(text, changedRow)
  19.         End If
  20.     End If
  21. End Sub

  23. Sub BasicConditionCheck(ByVal text As String, ByVal row As Long)
  24.     ' 判断字符串中是否包含 "无缝", "钢管" 且不包含 "锌", "zinc", "galv"
  25.     If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 Then
  26.         If InStr(text, "锌") = 0 And InStr(text, "zinc") = 0 And InStr(text, "galv") = 0 Then
  27.             Cells(row, "H").Value = "无缝钢管"
  28.             
  29.             ' 后续判定并赋值I, J, K列
  30.             AssignStandards_I text, row
  31.             AssignMaterials_J text, row
  32.             AssignDimensions_K text, row
  33.         ElseIf InStr(text, "锌") > 0 Or InStr(text, "zinc") > 0 Or InStr(text, "galv") > 0 Then
  34.             Cells(row, "H").Value = "无缝钢管(镀锌)"
  35.         End If
  36.     End If
  37. End Sub

  39. Sub AssignStandards_I(ByVal text As String, ByVal row As Long)
  40.     Select Case True
  41.         Case InStr(text, "3405") > 0
  42.             Cells(row, "I").Value = "SH/T3405"
  43.         Case InStr(text, "36.10") > 0
  44.             Cells(row, "I").Value = "ASME B36.10"
  45.         Case InStr(text, "36.19") > 0
  46.             Cells(row, "I").Value = "ASME B36.19"
  47.         Case InStr(text, "20553") > 0
  48.             If InStr(text, "a") > 0 Then
  49.                 Cells(row, "I").Value = "HG/T20553(Ⅰa)"
  50.             ElseIf InStr(text, "b") > 0 Then
  51.                 Cells(row, "I").Value = "HG/T20553(Ⅰb)"
  52.             ElseIf InStr(text, "Ⅱ") > 0 Then
  53.                 Cells(row, "I").Value = "HG/T20553(Ⅱ)"
  54.             End If
  55.         Case InStr(text, "17395") > 0
  56.             If InStr(text, "Ⅰ") > 0 Then
  57.                 Cells(row, "I").Value = "GB/T17395(Ⅰ)"
  58.             ElseIf InStr(text, "Ⅱ") > 0 Then
  59.                 Cells(row, "I").Value = "GB/T17395(Ⅱ)"
  60.             ElseIf InStr(text, "Ⅲ") > 0 Then
  61.                 Cells(row, "I").Value = "GB/T17395(Ⅲ)"
  62.             End If
  63.     End Select
  64. End Sub

  66. Sub AssignMaterials_J(ByVal text As String, ByVal row As Long)
  67.     Select Case True
  68.         Case InStr(text, "20") > 0 And InStr(text, "8163") > 0
  69.             Cells(row, "J").Value = "20-GB/T8163"
  70.         Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
  71.             Cells(row, "J").Value = "20-GB/T9948"
  72.         Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
  73.             Cells(row, "J").Value = "20-GB/T3087"
  74.         Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
  75.             Cells(row, "J").Value = "20G-GB/T5310"
  76.         Case InStr(text, "15Cr") > 0 And InStr(text, "9948") = 0
  77.             Cells(row, "J").Value = "15CrMoG-GB/T5310"
  78.         Case InStr(text, "12Cr") > 0
  79.             Cells(row, "J").Value = "12Cr1MoVG-GB/T5310"
  80.         Case InStr(text, "15CrMo") > 0 And InStr(text, "9948") > 0
  81.             Cells(row, "J").Value = "15CrMo-GB/T9948"
  82.         Case InStr(text, "30403") > 0
  83.             Cells(row, "J").Value = "S30403-GB/T14976"
  84.         Case InStr(text, "316") > 0
  85.             Cells(row, "J").Value = "S31603-GB/T14976"
  86.         Case InStr(text, "310") > 0
  87.             Cells(row, "J").Value = "S31008-GB/T14976"
  88.         Case InStr(text, "2205") > 0
  89.             Cells(row, "J").Value = "S22053-GB/T14976"
  90.         Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
  91.             Cells(row, "J").Value = "S30408-GB/T13296"
  92.         Case InStr(text, "304") > 0 And InStr(text, "312") > 0
  93.             Cells(row, "J").Value = "TP304-A312"
  94.         Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
  95.             Cells(row, "J").Value = "S30408-GB/T14976"
  96.     End Select
  97. End Sub

  99. Sub AssignDimensions_K(ByVal text As String, ByVal row As Long)
  100.     Dim pattern As String
  101.     Dim match As Object
  102.     Dim regex As Object

  104.     ' 正则表达式查找形如 "Φ133x4", "Φ133x4.5", "Φ45*4.5"
  105.     pattern = "Φ\d+[\*x]\d+\.?\d*"
  106.    
  107.     Set regex = CreateObject("VBScript.RegExp")
  108.     With regex
  109.         .Pattern = pattern
  110.         .Global = False
  111.         .IgnoreCase = True
  112.     End With

  114.     If regex.Test(text) Then
  115.         Set match = regex.Execute(text)(0)
  116.         Cells(row, "K").Value = match.Value
  117.     End If
  118. End Sub
复制代码


此代码通过事件处理和分支判断实现了所需功能。其中：

- `Worksheet_Change` 事件函数用于监控特定列的变化，触发相应的操作。
- `BasicConditionCheck` 用于基础条件判断，并调用其他子程序对特定列进行操作。
- `AssignStandards_I` 和 `AssignMaterials_J` 用于在满足条件时填充I和J列。
- `AssignDimensions_K` 使用正则表达式查找特定格式的数据并赋值K列。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

颂风侯
 楼主| 发表于 2024-12-27 16:35:44 | 显示全部楼层
考虑写一个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(Ⅲ)"；
在"判断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","φ45*4.5"这些类型的数据，将该单元格所在行的K列单元格赋值为"Φ？？*？？"数据；



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

要求该代码以VBA写，且重复得用sub，function进行封装简化，保证后续程序重复调用，并且充分得写注释
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

FishC
发表于 2024-12-27 16:36:24 | 显示全部楼层
颂风侯 发表于 2024-12-27 16:35
考虑写一个excel工作表change的事件
如果行数大于3， ...

  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim changedRow As Long
  3.     Dim concatenatedText As String

  5.     ' 仅监听列B, C, D, E的修改
  6.     If Not Intersect(Target, Me.Range("B:E")) Is Nothing Then
  7.         changedRow = Target.Row

  9.         ' 确保所改变的行大于3
  10.         If changedRow > 3 Then
  11.             ' 清空H, I, J, K列
  12.             Me.Range("H" & changedRow & ":K" & changedRow).ClearContents
  13.             
  14.             ' 合并B, C, D, E列内容为单个字符串
  15.             concatenatedText = Join(Application.Transpose(Application.Transpose(Me.Range("B" & changedRow & ":E" & changedRow).Value)), "")
  16.             
  17.             ' 条件判断和赋值
  18.             If CheckSeamlessPipe(concatenatedText) Then
  19.                 Me.Cells(changedRow, "H").Value = "无缝钢管"
  20.                 AssignStandards_I concatenatedText, changedRow
  21.                 AssignMaterials_J concatenatedText, changedRow
  22.                 AssignDimensions_K concatenatedText, changedRow
  23.             ElseIf CheckGalvanizedPipe(concatenatedText) Then
  24.                 Me.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
  25.             End If
  26.         End If
  27.     End If
  28. End Sub

  30. Function CheckSeamlessPipe(ByVal text As String) As Boolean
  31.     ' 检查是否为无缝钢管且不含锌
  32.     CheckSeamlessPipe = InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And _
  33.                         InStr(text, "锌") = 0 And InStr(text, "zinc") = 0 And InStr(text, "galv") = 0
  34. End Function

  36. Function CheckGalvanizedPipe(ByVal text As String) As Boolean
  37.     ' 检查是否为镀锌无缝钢管
  38.     CheckGalvanizedPipe = InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And _
  39.                           (InStr(text, "锌") > 0 Or InStr(text, "zinc") > 0 Or InStr(text, "galv") > 0)
  40. End Function

  42. Sub AssignStandards_I(ByVal text As String, ByVal row As Long)
  43.     ' 设置I列标准
  44.     Select Case True
  45.         Case InStr(text, "3405") > 0
  46.             Cells(row, "I").Value = "SH/T3405"
  47.         Case InStr(text, "36.10") > 0
  48.             Cells(row, "I").Value = "ASME B36.10"
  49.         Case InStr(text, "36.19") > 0
  50.             Cells(row, "I").Value = "ASME B36.19"
  51.         Case InStr(text, "20553") > 0
  52.             If InStr(text, "a") > 0 Then
  53.                 Cells(row, "I").Value = "HG/T20553(Ⅰa)"
  54.             ElseIf InStr(text, "b") > 0 Then
  55.                 Cells(row, "I").Value = "HG/T20553(Ⅰb)"
  56.             ElseIf InStr(text, "Ⅱ") > 0 Then
  57.                 Cells(row, "I").Value = "HG/T20553(Ⅱ)"
  58.             End If
  59.         Case InStr(text, "17395") > 0
  60.             If InStr(text, "Ⅰ") > 0 Then
  61.                 Cells(row, "I").Value = "GB/T17395(Ⅰ)"
  62.             ElseIf InStr(text, "Ⅱ") > 0 Then
  63.                 Cells(row, "I").Value = "GB/T17395(Ⅱ)"
  64.             ElseIf InStr(text, "Ⅲ") > 0 Then
  65.                 Cells(row, "I").Value = "GB/T17395(Ⅲ)"
  66.             End If
  67.     End Select
  68. End Sub

  70. Sub AssignMaterials_J(ByVal text As String, ByVal row As Long)
  71.     ' 设置J列材料
  72.     Select Case True
  73.         Case InStr(text, "20") > 0 And InStr(text, "8163") > 0
  74.             Cells(row, "J").Value = "20-GB/T8163"
  75.         Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
  76.             Cells(row, "J").Value = "20-GB/T9948"
  77.         Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
  78.             Cells(row, "J").Value = "20-GB/T3087"
  79.         Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
  80.             Cells(row, "J").Value = "20G-GB/T5310"
  81.         Case InStr(text, "15Cr") > 0 And InStr(text, "9948") = 0
  82.             Cells(row, "J").Value = "15CrMoG-GB/T5310"
  83.         Case InStr(text, "12Cr") > 0
  84.             Cells(row, "J").Value = "12Cr1MoVG-GB/T5310"
  85.         Case InStr(text, "15CrMo") > 0 And InStr(text, "9948") > 0
  86.             Cells(row, "J").Value = "15CrMo-GB/T9948"
  87.         Case InStr(text, "30403") > 0
  88.             Cells(row, "J").Value = "S30403-GB/T14976"
  89.         Case InStr(text, "316") > 0
  90.             Cells(row, "J").Value = "S31603-GB/T14976"
  91.         Case InStr(text, "310") > 0
  92.             Cells(row, "J").Value = "S31008-GB/T14976"
  93.         Case InStr(text, "2205") > 0
  94.             Cells(row, "J").Value = "S22053-GB/T14976"
  95.         Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
  96.             Cells(row, "J").Value = "S30408-GB/T13296"
  97.         Case InStr(text, "304") > 0 And InStr(text, "312") > 0
  98.             Cells(row, "J").Value = "TP304-A312"
  99.         Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
  100.             Cells(row, "J").Value = "S30408-GB/T14976"
  101.     End Select
  102. End Sub

  104. Sub AssignDimensions_K(ByVal text As String, ByVal row As Long)
  105.     Dim pattern As String
  106.     Dim regex As Object
  107.     Dim matches As Object

  109.     ' 使用正则表达式匹配类似"Φ133x4","Φ133x4.5","Φ45*4.5","φ45*4.5"的模式
  110.     pattern = "Φ[\d.]+x[\d.]+|Φ[\d.]+\*[\d.]+|φ[\d.]+x[\d.]+|φ[\d.]+\*[\d.]+"
  111.     Set regex = CreateObject("VBScript.RegExp")
  112.    
  113.     ' 配置正则对象
  114.     With regex
  115.         .Pattern = pattern
  116.         .Global = False
  117.         .IgnoreCase = True
  118.     End With

  120.     ' 如果符合匹配条件，则赋值K列
  121.     If regex.Test(text) Then
  122.         Set matches = regex.Execute(text)
  123.         Cells(row, "K").Value = matches(0).Value
  124.     End If
  125. End Sub
复制代码


以上代码实现了所需逻辑，包括：
1. 根据内容在H列进行基本判断。
2. 在满足基本判断的基础上将特定内容赋值到I列和J列。
3. 使用正则表达式将特定格式（如Φ133x4）的内容赋值到K列。
4. 各功能通过封装成独立的Sub或Function来实现，以便代码复用和维护。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

颂风侯
 楼主| 发表于 2024-12-27 16:40:45 | 显示全部楼层
Sub AssignDimensions_K(ByVal text As String, ByVal row As Long)
  Dim pattern As String
  Dim match As Object
  Dim regex As Object

  ' 正则表达式查找形如 "Φ133x4", "Φ133x4.5", "Φ45*4.5"
  pattern = "Φ[\d.]+x[\d.]+|Φ[\d.]+\*[\d.]+|φ[\d.]+x[\d.]+|φ[\d.]+\*[\d.]+"

  Set regex = CreateObject("VBScript.RegExp")
  With regex
  .pattern = pattern
  .Global = False
  .IgnoreCase = True
  End With

  If regex.Test(text) Then
  Set match = regex.Execute(text)(0)
  Cells(row, "K").Value = match.Value
  End If
End Sub

这里错误，提示运行时错误1004
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

FishC
发表于 2024-12-27 16:41:00 | 显示全部楼层
颂风侯 发表于 2024-12-27 16:40
Sub AssignDimensions_K(ByVal text As String, ByVal ...


整理正则表达式用法有误。正则表达式的`Pattern`应该能够准确匹配字符串中的格式。在这一问题中，我们需要寻找的模式可以描述为“一个大写或小写的Φ（或φ）后面跟随一组数字，然后是x或*，再跟随一组数字”。正则表达式模式中也需要适当调整以确保大写和小写的匹配。

请尝试以下调整后的代码：

  1. Sub AssignDimensions_K(ByVal text As String, ByVal row As Long)
  2.     Dim pattern As String
  3.     Dim matches As Object
  4.     Dim regex As Object

  6.     ' 正则表达式查找形如 "Φ133x4", "Φ133x4.5", "Φ45*4.5", "φ45*4.5"
  7.     pattern = "Φ\d+x\d+(\.\d+)?|φ\d+\*\d+(\.\d+)?"

  9.     Set regex = CreateObject("VBScript.RegExp")
  10.     With regex
  11.         .Pattern = pattern
  12.         .Global = False
  13.         .IgnoreCase = True
  14.     End With

  16.     If regex.Test(text) Then
  17.         Set matches = regex.Execute(text)
  18.         Cells(row, "K").Value = matches(0).Value
  19.     End If
  20. End Sub
复制代码


注意：
1. 使用`\d+`以匹配一个或多个数字。
2. `(\.\d+)?`表示可选的小数部分匹配。
3. 确保对于大小写不同的Φ（phi）使用正确的字符"Φ"和"φ"。

以上修正应解决代码中的错误，并正确匹配所需的字符串格式。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

颂风侯
 楼主| 发表于 2024-12-27 17:24:16 | 显示全部楼层
Sub AssignDimensions_K(ByVal text As String, ByVal row As Long)
    Dim pattern As String
    Dim matches As Object
    Dim regex As Object

     ' 正则表达式查找形如 "Φ133x4", "Φ133x4.5", "Φ45*4.5", "φ45*4.5"
    pattern = "Φ\d+x\d+(\.\d+)?|φ\d+\*\d+(\.\d+)?"

    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .pattern = pattern
        .Global = False
        .IgnoreCase = True
    End With

    If regex.Test(text) Then
        Set matches = regex.Execute(text)
        Cells(row, "K").Value = matches(0).Value
    End If
End Sub
还是错误的。。。
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

FishC
发表于 2024-12-27 17:24:31 | 显示全部楼层
颂风侯 发表于 2024-12-27 17:24
Sub AssignDimensions_K(ByVal text As String, ByVal ...


出现运行时错误的原因可能是正则表达式没有正确匹配您的数据格式。我们需要确保正则表达式能够匹配到正确格式的数据。在此例中，我们要搜索的数据类型为“Φ133x4”、“Φ133x4.5”、“φ45*4.5”等，正则表达式的模式应该准确捕获这些格式。

请尝试以下调整后的代码，它旨在捕获您指定的数据格式：

  1. Sub AssignDimensions_K(ByVal text As String, ByVal row As Long)
  2.     Dim pattern As String
  3.     Dim matches As Object
  4.     Dim regex As Object

  6.     ' 正则表达式查找形如 "Φ133x4", "Φ133x4.5", "Φ45*4.5", "φ45*4.5"
  7.     pattern = "[Φφ]\d+(\.\d+)?[x\*]\d+(\.\d+)?"

  9.     Set regex = CreateObject("VBScript.RegExp")
  10.     With regex
  11.         .Pattern = pattern
  12.         .Global = False
  13.         .IgnoreCase = True
  14.     End With

  16.     If regex.Test(text) Then
  17.         Set matches = regex.Execute(text)
  18.         Cells(row, "K").Value = matches(0).Value
  19.     End If
  20. End Sub
复制代码


### 说明：
1. `"[Φφ]\d+(\.\d+)?[x\*]\d+(\.\d+)?"` 用于匹配：
   - `[Φφ]`：匹配“Φ”或“φ”。
   - `\d+`：匹配一个或多个数字。
   - `(\.\d+)?`：匹配可选的小数部分。
   - `[x\*]`：匹配字母'x'或字符'*'。
   - 结尾的 `\d+(\.\d+)?` 与前面的格式对称，捕获最后的数字或小数。

2. 请确保输入数据格式正确，并确认是否含有指定字符。

这段代码在单元格内执行正则表达式并将匹配到的内容显示在 K 列。确保 `text` 包含目标字符串，以便正则表达式成功提取并显示结果。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

颂风侯
 楼主| 发表于 2024-12-27 17:33:09 | 显示全部楼层
在"判断1.1"的基础上增加判断，
如果字符串包含类似于"133x4","133x4.5","45*4.5"这些类型的数据，将该单元格所在行的K列单元格赋值为"Φ？？*？？"数据；
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

FishC
发表于 2024-12-27 17:44:33 | 显示全部楼层
颂风侯 发表于 2024-12-27 17:33
在"判断1.1"的基础上增加判断，
如果字符串包含类似 ...


明白了，如果要匹配类似于“133x4”、“133x4.5”或“45*4.5”的数据，并将其格式化为“Φ??*??”并赋值到K列，可以使用以下代码：

  1. Sub AssignDimensions_K(ByVal text As String, ByVal row As Long)
  2.     Dim pattern As String
  3.     Dim matches As Object
  4.     Dim regex As Object
  5.     Dim formattedValue As String

  7.     ' 正则表达式查找形如 "133x4", "133x4.5", "45*4.5"
  8.     pattern = "\d+(\.\d+)?[x*]\d+(\.\d+)?"

  10.     Set regex = CreateObject("VBScript.RegExp")
  11.     With regex
  12.         .Pattern = pattern
  13.         .Global = False
  14.         .IgnoreCase = True
  15.     End With

  17.     If regex.Test(text) Then
  18.         Set matches = regex.Execute(text)
  19.         formattedValue = Replace(matches(0).Value, "x", "*")
  20.         formattedValue = Replace(formattedValue, "X", "*")
  21.         Cells(row, "K").Value = "Φ" & formattedValue
  22.     End If
  23. End Sub
复制代码


### 说明：

1. **正则表达式模式** (`pattern`):
   - `\d+(\.\d+)?`: 匹配一个或多个数字，可以有可选的小数部分。
   - `[x*]`: 在"x"或"*"两个字符之间进行匹配。
   - 第二个`\d+(\.\d+)?`用于匹配"x"或"*"之后的数字或小数。

2. **代码逻辑**:
   - 使用正则表达式匹配 `text` 中是否含有指定的数字-分隔符-数字模式。
   - 使用 `Replace` 函数确保"x"和"X"都被替换为"*"，以标准化输出格式。
   - 将结果格式化为“Φ??*??”并赋值到相应行的K列。

确认输入数据格式遵循上述描述以确保成功匹配并处理。

以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。
小甲鱼最新课程 -> https://ilovefishc.com
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

小黑屋|手机版|Archiver|鱼C工作室 ( 粤ICP备18085999号-1 | 粤公网安备 44051102000585号)

GMT+8, 2025-5-10 05:09

Powered by Discuz! X3.4

© 2001-2023 Discuz! Team.

快速回复 返回顶部 返回列表