相同的内容分类

卢嘉轩 · 发表于 2023-5-20 07:10

相同内容相同的标记.rar (9.06 KB, 下载次数: 6) 求相同内容相同的标记。

3190496160 · 发表于 2023-5-20 08:12

Sub 标记()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "不成立订单导入表 (二次筛选)为空！": End
.Range("a1:q" & r).Interior.ColorIndex = 0
ar = .Range("a1:q" & r)
For i = 2 To UBound(ar)
      If Trim(ar(i, 2)) <> "" And Trim(ar(i, 14)) <> "" Then
         zd = Trim(ar(i, 2)) & "|" & Trim(ar(i, 14))
         d(zd) = d(zd) + 1
         .Cells(i, 17) = d(zd)
         .Cells(i, 2).Interior.ColorIndex = d(zd) + 2
         .Cells(i, 14).Interior.ColorIndex = d(zd) + 2
         .Cells(i, 17).Interior.ColorIndex = d(zd) + 2
      End If
Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2023-5-20 08:12

3190496160 · 发表于 2023-5-20 08:13

结果未核对，代码仅供参考

相同内容相同的标记.rar (15.67 KB, 下载次数: 12)

笨鸟飞不高 · 发表于 2023-5-20 08:20

相同内容相同的标记.zip (17.6 KB, 下载次数: 10)

gwjkkkkk · 发表于 2023-5-20 19:05

参与一下。。。

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

[求助] 相同的内容分类