|
|
楼主 |
发表于 2024-12-29 15:56:05
|
显示全部楼层
Private Sub Worksheet_Change(ByVal Target As Range)
Dim changedRow As Long
Dim text As String
Dim LastRowDest As Long
Dim SearchRange As String
' Dim KeyCells As Range ' 移除未使用的变量声明
Dim KeyCell As Range
Dim FoundCell As Range
Dim foundmatch As Boolean
Dim i As Long
Application.ScreenUpdating = False
' 设置工作表
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")
Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Sheets("Sheet2")
' 监控范围：B, C, D, E 列
If Not Intersect(Target, wsSource.Range("B:E")) Is Nothing Then
For Each KeyCell In Target ' 遍历Target中的每个单元格
changedRow = KeyCell.row ' 修正：使用KeyCell.Row
' 如果行数大于3
If changedRow > 3 Then
' 清空该行的H, I, J, K单元格的数据
wsSource.Range("H" & changedRow & ":K" & changedRow).ClearContents
' 取消背景颜色设置
wsSource.Range("H" & changedRow & ":K" & changedRow).Interior.Color = xlNone
' 合并B, C, D, E列内容为一个字符串
Dim arrValues As Variant
arrValues = wsSource.Range("B" & changedRow & ":E" & changedRow).Value
text = Join(Application.Transpose(Application.Transpose(arrValues)), ",")
' 第一个判断：无缝钢管且不含锌
If CheckBasicCondition_wfgg(text) Then
wsSource.Cells(changedRow, "H").Value = "无缝钢管"
' 后续条件分析并赋值I, J列
AssignStandards_I_wfgg text, changedRow
AssignMaterials_K_wfgg text, changedRow
AssignDimensions_J_wfgg text, changedRow
End If
' 第二个判断：无缝钢管且含锌
If CheckBasicCondition_dxwfgg(text) Then
wsSource.Cells(changedRow, "H").Value = "无缝钢管(镀锌)"
End If
End If
Next KeyCell
End If
' 确定变动的单元格是否在H到K列
' 监控范围：H, I, J, K 列
If Not Intersect(Target, wsSource.Range("H:K")) Is Nothing Then
For Each KeyCell In Intersect(Target, wsSource.Range("H:K"))
changedRow = KeyCell.row
' 如果行数大于3
If changedRow > 3 Then
' 清空该行的L单元格的数据
wsSource.Cells(changedRow, "L").ClearContents
' 确定查找范围
LastRowDest = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).row
SearchRange = "B1:E" & LastRowDest
' 初始化匹配标志
foundmatch = False
' 在Sheet2的B到E列查找匹配的行
For i = 1 To LastRowDest
' 比较Sheet1的H列与Sheet2的B列，I列与C列，J列与D列，K列与E列
If wsSource.Cells(changedRow, "H").Value = wsDest.Cells(i, "B").Value And _
wsSource.Cells(changedRow, "I").Value = wsDest.Cells(i, "C").Value And _
wsSource.Cells(changedRow, "J").Value = wsDest.Cells(i, "D").Value And _
wsSource.Cells(changedRow, "K").Value = wsDest.Cells(i, "E").Value Then
' 如果找到匹配的行，复制Sheet2的F列值到Sheet1的L列
wsSource.Cells(changedRow, "L").Value = wsDest.Cells(i, "F").Value
foundmatch = True
Exit For ' 找到匹配后退出循环
End If
Next i
' 如果没有找到匹配的行，L列保持清空状态
End If
Next KeyCell
End If
Application.ScreenUpdating = True
End Sub
'无缝钢管，不含镀锌的判断
Function CheckBasicCondition_wfgg(ByVal text As String) As Boolean
If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And (InStr(text, "锌") = 0 And InStr(text, "zinc") = 0 And InStr(text, "galv") = 0) Then
CheckBasicCondition_wfgg = True
Else
CheckBasicCondition_wfgg = False
End If
End Function
'镀锌无缝钢管的判断
Function CheckBasicCondition_dxwfgg(ByVal text As String) As Boolean
If InStr(text, "无缝") > 0 And InStr(text, "钢管") > 0 And (InStr(text, "锌") > 0 Or InStr(text, "zinc") > 0 Or InStr(text, "galv") > 0) Then
CheckBasicCondition_dxwfgg = True
Else
CheckBasicCondition_dxwfgg = False
End If
End Function
Sub AssignStandards_I_wfgg(ByVal text As String, ByVal row As Long)
Application.ScreenUpdating = False
' 根据文本内容，为I列 标准 赋值
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")
If InStr(text, "3405") > 0 Then
wsSource.Cells(row, "I").Value = "SH/T3405"
ElseIf InStr(text, "36.10") > 0 Then
wsSource.Cells(row, "I").Value = "ASME B36.10"
ElseIf InStr(text, "36.19") > 0 Then
wsSource.Cells(row, "I").Value = "ASME B36.19"
ElseIf InStr(text, "20553") > 0 Then
Select Case True
Case InStr(text, "a") > 0
wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰa)"
Case InStr(text, "b") > 0
wsSource.Cells(row, "I").Value = "HG/T20553(Ⅰb)"
Case InStr(text, "Ⅱ") > 0
wsSource.Cells(row, "I").Value = "HG/T20553(Ⅱ)"
Case Else
With wsSource.Cells(row, "I")
.Value = "请下拉选择"
' 设置背景颜色为黄色
.Interior.Color = RGB(255, 255, 0)
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="HG/T20553(Ⅰa),HG/T20553(Ⅱ),HG/T20553(Ⅰb)"
End With
End Select
ElseIf InStr(text, "17395") > 0 Then
Select Case True
Case InStr(text, "Ⅰ") > 0
wsSource.Cells(row, "I").Value = "GB/T17395(Ⅰ)"
Case InStr(text, "Ⅱ") > 0
wsSource.Cells(row, "I").Value = "GB/T17395(Ⅱ)"
Case InStr(text, "Ⅲ") > 0
wsSource.Cells(row, "I").Value = "GB/T17395(Ⅲ)"
Case Else
With wsSource.Cells(row, "I")
.Value = "请下拉选择"
' 设置背景颜色为黄色
.Interior.Color = RGB(255, 255, 0)
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="GB/T17395(Ⅰ),GB/T17395(Ⅱ),GB/T17395(Ⅲ)"
End With
End Select
Else
' 如果以上都没找到，设置下拉列表
With wsSource.Cells(row, "I")
.Value = "请下拉选择"
' 设置背景颜色为黄色
.Interior.Color = RGB(255, 255, 0)
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="SH/T3405,HG/T20553(Ⅰa),HG/T20553(Ⅱ),ASME B36.10,ASME B36.19,HG/T20553(Ⅰb)"
End With
End If
Application.ScreenUpdating = True
End Sub
Sub AssignMaterials_K_wfgg(ByVal text As String, ByVal row As Long)
' 根据文本内容，为K列 材质 赋值
Application.ScreenUpdating = False
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")
Select Case True
Case InStr(text, "20") > 0 And InStr(text, "8163") > 0
wsSource.Cells(row, "K").Value = "20-GB/T8163"
Case InStr(text, "20") > 0 And InStr(text, "9948") > 0
wsSource.Cells(row, "K").Value = "20-GB/T9948"
Case InStr(text, "20") > 0 And InStr(text, "3087") > 0
wsSource.Cells(row, "K").Value = "20-GB/T3087"
Case InStr(text, "20") > 0 And InStr(text, "5310") > 0
wsSource.Cells(row, "K").Value = "20G-GB/T5310"
Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0) And InStr(text, "9948") > 0
wsSource.Cells(row, "K").Value = "15CrMoG-GB/T9948"
Case InStr(text, "12Cr") > 0 Or InStr(text, "12cr") > 0
wsSource.Cells(row, "K").Value = "12Cr1MoVG-GB/T5310"
Case (InStr(text, "15Cr") > 0 Or InStr(text, "15cr") > 0)
wsSource.Cells(row, "K").Value = "15CrMo-GB/T5310"
Case InStr(text, "30403") > 0
wsSource.Cells(row, "K").Value = "S30403-GB/T14976"
Case InStr(text, "316") > 0
wsSource.Cells(row, "K").Value = "S31603-GB/T14976"
Case InStr(text, "310") > 0
wsSource.Cells(row, "K").Value = "S31008-GB/T14976"
Case InStr(text, "2205") > 0
wsSource.Cells(row, "K").Value = "S22053-GB/T14976"
Case InStr(text, "304") > 0 And InStr(text, "13296") > 0
wsSource.Cells(row, "K").Value = "S30408-GB/T13296"
Case InStr(text, "304") > 0 And InStr(text, "312") > 0
wsSource.Cells(row, "K").Value = "TP304-A312"
Case InStr(text, "304") > 0 And InStr(text, "30403") = 0
wsSource.Cells(row, "K").Value = "S30408-GB/T14976"
Case Else
With wsSource.Cells(row, "K")
.Value = "请下拉选择"
' 设置背景颜色为黄色
.Interior.Color = RGB(255, 255, 0)
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="20-GB/T8163,20-GB/T3087,20G-GB/T5310,S30408-GB/T14976,S31603-GB/T14976,15CrMoG-GB/T5310,12Cr1MoVG-GB/T5310,S31008-GB/T14976,15CrMoG-GB/T9948,20-GB/T9948,S30403-GB/T14976,S22053-GB/T14976"
End With
End Select
Application.ScreenUpdating = True
End Sub
Sub AssignDimensions_J_wfgg(ByVal text As String, ByVal row As Long)
' 根据文本内容，为J列 规格 赋值
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("Sheet1")
Dim regex As Object
Dim matches As Object
Dim matchPattern As String
Application.ScreenUpdating = False
matchPattern = "(\d+(\.\d+)?)\s*[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
这个代码运算很慢，有没有办法优化下提高速度 |
|
( 粤ICP备18085999号-1 | 粤公网安备 44051102000585号)
狗仔卡
发表于 2024-12-29 13:34:02
置顶卡
千斤顶
显身卡
发表于 2024-12-29 13:34:34
