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

一把小刀闯天下

约定的童话 发表于 2018-7-19 07:23
有没有那种就是在一个单元格内显重的？百度了好久都没找到，像这个U9,先遍历E列，在每个单元格内查重，然后 ...

有图有真相，哈哈哈

约定的童话

敲死我了（敲了7遍...），大神，图片杀伤力太大了，你直接上源码吧

约定的童话

总算敲出来了，大神，非常感谢，没想到这个U9匹配了那么多逻辑代码

sunny_8848

重复数字着色，有用到过。多谢分享

约定的童话

sunny_8848 发表于 2018-7-19 10:34
重复数字着色，有用到过。多谢分享

这个代码很神奇，单独的单元格内容重复着色，列单元格内容着色都可以

一把小刀闯天下

约定的童话 发表于 2018-7-19 12:37
这个代码很神奇，单独的单元格内容重复着色，列单元格内容着色都可以

'不神奇就是按这要求来写的。看来问题搞定了，那就贴代码了，因为这代码还有点通用，如果谁遇到了类似的问题稍作修改就能用

Option Explicit

Sub test()
  Dim arr, i, j, t, dic, key, row, pos
  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
      t = Replace(Cells(i, "e").Value, Space(1), vbNullString)
      t = Replace(t, "，", ",")
      t = Replace(t, "'", vbNullString)
      If InStr(t, ",") Then
        t = Split(t, ",")
        For j = 0 To UBound(t)
          If dic(t(j)) > 1 Then
            pos = 1
            Do
              pos = InStr(pos, Cells(i, "e"), t(j))
              If pos > 0 Then
                Cells(i, "e").Characters(pos, Len(t(j))).Font.Color = vbRed
                pos = pos + 1
              Else
                Exit Do
              End If
            Loop
          End If
        Next
      Else
        If dic(t) > 1 Then Cells(i, "e").Font.Color = vbRed
      End If
    End If
  Next
End Sub

约定的童话

的确如此，横竖通吃，小李飞刀果然名不虚传！赞....