对匹配的风险物质进行汇总（涉及合并单元格）

边缘码农 · 发表于 2024-7-3 07:57

化妆品中安全性风险物质危害识别表

这是不是每个配方表的表名中都有的内容？

边缘码农 · 发表于 2024-7-3 09:33

根据我的理解，修改一版。
附注的描述结构和描述词汇采用上次的单配方版本。

边缘码农 · 发表于 2024-7-3 09:34

Sub 数据筛选()
'---------------------------
Dim List1 As String ' 产品列表
Dim ListCp As String ' 产品描述字符串
Dim ListYL As String ' 原料描述字符串
Dim Now() As String ' 当前单元格的内容数组，分割形成
Dim i As Long, J As Long, R As Long, X As Long '循环变量
Dim TotalRow As Long '合并单元格的行数
Dim Jgxh As Long ' 结果序号
Dim Ylxh As Long ' 原料序号
Dim Jg As String ' 最终描述结果
Dim NowRow As Long '当前行
Dim RngText As String ' 单元格类型
Dim NamePF() As String '配方名称数组，配方表名称分割形成
Dim PFName As String '配方名称
Dim Pffx As Boolean '配方分析
'---------------------------
List1 = "二噁烷、游离甲醛、甲醇、石棉"
' 删除工作表"附录 (新增)"中第3行及之后的数据
With Sheets("附录 (新增)")
TotalRow = .Cells(.Rows.Count, 3).End(xlUp).Row
If TotalRow > 2 Then .Range("b3:C" & TotalRow).ClearContents
End With
With Sheets("风险物质安评（新增）")
'---------------------
' 检测工作表"风险物质安评（新增）"
R = .Cells(Rows.Count, 3).End(xlUp).Row
If R < 8 Then
MsgBox "数据源为空！"
End '退出
End If
'---------------------
Jgxh = 1
For i = 6 To R
' 从第6行开始判断。要求工作表的格式固定，1-5行为固定的内容。
' 因为数据量小，直接操作工作表。
'-------------------------------------
' 判断当前单元格的类型
RngText = Merge(.Cells(i, 2))
If RngText = "1行多列合并" Then
' 当前单元格是1行多列合并，是配方表的名称。
' 取得配方名称
NamePF = Split(Delkg(.Cells(i, 2)), " ")
If UBound(NamePF) >= 2 Then
' 配方表名称分割后的数组成员数>=2，说明配方表名称有3部分组成，含有配方名称
PFName = NamePF(1)
Else
PFName = ""
End If
If InStr(.Cells(i, 2), "合并") = 0 Then
'配方表的名称中不包含“合并”二字，需要进行分析
Pffx = True
Else
Pffx = False
End If
End If
'-------------------------------------
If Pffx Then
If IsNumeric(.Cells(i, 2)) Then
' 如果当前单元格的内容是数值
TotalRow = 1
' 取得合并单元格的行数
Ylxh = 0
With .Cells(i, 2)
If .MergeCells Then
' 是合并单元格，取得合并单元格的行数
TotalRow = .MergeArea.Rows.Count
If Ylxh = 0 Then Ylxh = .Value
Else
Ylxh = .Value
End If
End With
For J = 1 To TotalRow
' 按照合并单元格的行数循环
Debug.Print .Cells(i + J - 1, 4)
If .Cells(i + J - 1, 4) <> "无" Then
Now = Split(.Cells(i + J - 1, 4), "、") ' 取得当前行与C列交叉单元格的内容，分割到数组。
For X = 0 To UBound(Now)
If InStr(List1, Now(X)) > 0 Then
' 在产品列表中
' ListCp = ListCp & Now(X) & "、"
If InStr(ListCp, Now(X)) = 0 Then ListCp = ListCp & Now(X) & "、" '对同个原料中对应产品检验报告的风险物质去重
Else
' ListYL = ListYL & Now(X) & "、"
If InStr(ListYL, Now(X)) = 0 Then ListYL = ListYL & Now(X) & "、" '对同个原料中其他风险物质去重
End If
Next
End If
Next
If ListCp <> "" Then
ListCp = Left(ListCp, Len(ListCp) - 1)
Jg = Jg & "产品中" & ListCp & "含量的检验报告、"
End If
If ListYL <> "" Then
ListYL = Left(ListYL, Len(ListYL) - 1)
Jg = Jg & "原料中" & ListYL & "含量的原料质量规格证明资料。"
End If
If Jg <> "" Then
With Sheets("附录 (新增)")
NowRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
.Cells(NowRow, 2) = Jgxh & "、"
.Cells(NowRow, 3) = PFName & " 配方中" & Ylxh & "号原料：" & Jg
Jg = ""
ListCp = ""
ListYL = ""
Jgxh = Jgxh + 1
End With
End If
i = i + J - 2
End If
End If
Next i
End With
MsgBox "ok!"
End Sub
Function Merge(Rng As Range) As String
'-----------------------------------------------
' 判断单元格是不是合并单元格，合并单元格的方向。
' 返回值：
' 正常：非合并单元格
' 1列多行合并
' 1行多列合并
' 多行多列合并
'-----------------------------------------------
' 定义单元格地址数组
Dim RngDZ() As String
Dim RngDZ1() As String
Dim RngDZ2() As String
If Rng.MergeCells Then
' 是合并单元格
RngDZ = Split(Rng.MergeArea.Address, ":")
RngDZ1 = Split(RngDZ(0), "$")
RngDZ2 = Split(RngDZ(1), "$")
If RngDZ1(1) = RngDZ2(1) Then
Merge = "1列多行合并"
Else
If RngDZ1(2) = RngDZ2(2) Then
Merge = "1行多列合并"
Else
Merge = "多行多列合并"
End If
End If
Else
' 不是合并单元格
Merge = "正常"
End If
End Function
Function Delkg(Textlist As String) As String
'-----------------------------------------------
' 删除多余的空格
'-----------------------------------------------
Dim i As Long ' 循环变量
Dim pp As String ' 是否空格
pp = "否"
For i = 1 To Len(Textlist)
kk = Mid(Textlist, i, 1)
If kk = " " Then
If pp = "否" Then
pp = "是"
Delkg = Delkg & kk
End If
Else
pp = "否"
Delkg = Delkg & kk
End If
Next
End Function

复制代码

边缘码农 · 发表于 2024-7-3 09:35

回复的代码在审核中。
代码中直接引用了工作表的名称，要确保工作表的名称和代码中的一致。
没有进行错误判断。

山海风云轩 · 发表于 2024-7-3 22:13

边缘码农发表于 2024-7-3 09:35
回复的代码在审核中。
代码中直接引用了工作表的名称，要确保工作表的名称和代码中的一致。
没有进行错误 ...

感谢大佬的相助，刚测试了一下，就是需要的效果！
非常感谢！！！

山海风云轩 · 发表于 2024-7-9 13:02

边缘码农发表于 2024-7-2 07:38
If InStr(ListCp, Now(X)) = 0 Then ListCp = ListCp & Now(X) & "、"

If InStr(ListYL, Now(X)) = 0 Th ...

再次请教大佬，这个代码是模糊去重的，比如同一个原料（多个组分对应多种风险物质）中有风险物质“苯”、“苯酚”，会将“苯”去重了，只剩下“苯酚”，请问要怎么样才可以精准去重了？

边缘码农 · 发表于 2024-7-9 17:24

山海风云轩发表于 2024-7-9 13:02
再次请教大佬，这个代码是模糊去重的，比如同一个原料（多个组分对应多种风险物质）中有风险物质“苯”、 ...

把运行结果和基础数据截一下图，或者把附件发上来，我现在不清楚基础资料是什么状况。我这边模拟了一下，应该没问题。

边缘码农 · 发表于 2024-7-9 17:27

找我有事，用回复，不然可能会漏掉。

山海风云轩 · 发表于 2024-7-9 20:22

边缘码农发表于 2024-7-9 17:27
找我有事，用回复，不然可能会漏掉。

好的，大佬，我发附件上来，已经模拟好情形了

山海风云轩 · 发表于 2024-7-9 20:23

这里是附件

		自动登录	找回密码
密码			免费注册

[求助] 对匹配的风险物质进行汇总（涉及合并单元格）

评分