楼主
liuguansky |
Q:零件名的数量是多个数量的加和，现在在返回各加和的明细，并且如果零件号有重复，进行提示
A:用如下事件代码可以实现：- Private Sub Worksheet_Change(ByVal Target As Range)
- If Target.Cells.Count = 1 Then
- '判断是否变动 单元格数为1
- If Not Application.Intersect(Target, Range("c:c")) Is Nothing Then
- '判断是否为C列变动
- Dim d, i&, dErr, Arr, Ar, StrF$, k As Byte
- '定义变量
- Set d = CreateObject("scripting.dictionary")
- '创建字典项目，用于零件号惟一
- Set dErr = CreateObject("scripting.dictionary")
- '创建字典项目，用于重复零件号惟一
- Arr = Range("A2:b" & Cells(Rows.Count, 1).End(3).Row).Value
- '获取数据源
- For i = 1 To UBound(Arr, 1)
- '循环数据源
- If d.exists(Arr(i, 1)) Then
- '如果存在零件号
- dErr(Arr(i, 1)) = ""
- '添加至重复零件号字典项目
- Else
- d.Add Arr(i, 1), i '否则添加零件号至字典项目，ITEM为行号
- End If
- Next i
- If d.exists(Target.Value) Then '判断变动零件号是否存在
- StrF = Cells(1 + d(Target.Value), 2).Formula '返回工作结果
- Ar = Split(Replace(StrF, "=", ""), "+") '获取加项
- If IsArray(Ar) Then
- k = UBound(Ar) + 1
- Else
- k = 1
- End If
- Range(Target.Offset(0, 1), Cells(Target.Row, Columns.Count)).ClearContents
- Target.Offset(0, 1).Resize(1, k).Value = Ar '返回加项结果
- Else
- Target.Offset(0, 1).Value = "未找到相关零件号。" '否则，提示未找到零件号
- End If
- If dErr.Count > 0 Then MsgBox "如下零件号存在重复记录，请核实：" & vbNewLine & Join(dErr.keys, ",")
- '如果存在重复零件号，则进行提示
- End If
- End If
- End Sub
|