如何用VBA在E6:E1000区域内进行查重并显色？

约定的童话

单元格里面内容不固定，以逗号区分！

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, t, dic, key, row
  Set dic = CreateObject("scripting.dictionary")
  row = Cells(Rows.Count, "e").End(xlUp).row
  arr = Range("e6:e" & row)
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 1)) Then
      t = Trim(arr(i, 1))
      If InStr(t, ",") Then
        t = Split(t, ",")
        For j = 0 To UBound(t)
          dic(Trim(t(j))) = dic(Trim(t(j))) + 1
        Next
      Else
        dic(t) = dic(t) + 1
      End If
    End If
  Next
  Cells(6, "e").Resize(row).Font.Color = vbBlack
  For i = 6 To row
    If Len(Cells(i, "e")) Then
      For Each key In dic.keys
        If InStr(Cells(i, "e"), key) Then
          If dic(key) > 1 Then
            Cells(i, "e").Characters(InStr(Cells(i, "e"), key), Len(key)).Font.Color = vbRed
          End If
        End If
      Next
    End If
  Next
End Sub

约定的童话

一把小刀闯天下 发表于 2018-7-17 16:04
Option Explicit

Sub test()

果然是大神啊，赐小弟一拜￥￥￥￥￥

jiminyanyan

约定的童话 发表于 2018-7-17 16:15
果然是大神啊，赐小弟一拜￥￥￥￥￥

无图无真相呀．．．

约定的童话

jiminyanyan 发表于 2018-7-17 19:30
无图无真相呀．．．

完美的实现了要求

lsc900707

约定的童话 发表于 2018-7-17 16:15
果然是大神啊，赐小弟一拜￥￥￥￥￥

拜就免了，可以试试论坛的感谢方式：点击对方帖子右下角“评分”按提示操作即可。

约定的童话

lsc900707 发表于 2018-7-18 11:04
拜就免了，可以试试论坛的感谢方式：点击对方帖子右下角“评分”按提示操作即可。

哈哈，学会了，都没注意到....

约定的童话

一把小刀闯天下 发表于 2018-7-17 16:04
Option Explicit

Sub test()

大神，代码对U9不起作用，为啥啊？愁死了[img]链接：https://pan.baidu.com/s/13DvCIwvtXBPZ9sSKQrppGg 密码：8obj链接：[url]https://pan.baidu.com/s/1uH2--Fn4AnZ6gTReeyhiOg 密码：e9r1[/url][/img]

一把小刀闯天下

约定的童话 发表于 2018-7-18 21:11
大神，代码对U9不起作用，为啥啊？愁死了

'格式问题,直接暴力解决

'其实[e12]也有问题

Option Explicit

Sub test()
  Dim arr, i, j, t, dic, key, row
  Set dic = CreateObject("scripting.dictionary")
  row = Cells(Rows.Count, "e").End(xlUp).row
  arr = Range("e6:e" & row)
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 1)) Then
      t = Replace(arr(i, 1), Space(1), vbNullString)
      t = Replace(t, "，", ",")
      t = Replace(t, "'", vbNullString)
      If InStr(t, ",") Then
        t = Split(t, ",")
        For j = 0 To UBound(t): dic(t(j)) = dic(t(j)) + 1: Next
      Else
        dic(t) = dic(t) + 1
      End If
    End If
  Next
  Cells(6, "e").Resize(row).Font.Color = vbBlack
  For i = 6 To row
    If Len(Cells(i, "e")) Then
      For Each key In dic.keys
        If InStr(Cells(i, "e"), key) Then
          If dic(key) > 1 Then
            Cells(i, "e").Characters(InStr(Cells(i, "e"), key), Len(key)).Font.Color = vbRed
          End If
        End If
      Next
    End If
  Next
End Sub

约定的童话

有没有那种就是在一个单元格内显重的？百度了好久都没找到，像这个U9,先遍历E列，在每个单元格内查重，然后再用你那个全局代码再次查重，这样就应该不会遗漏了