excel vba判断同行的内容是否重复

Sub a()
Dim d As Object  '定义变量
Dim i%, j%
For i = 1 To [a65536].End(3).Row
     Set d = CreateObject("Scripting.Dictionary") '创建数据字典
     For j = 1 To Cells(i, 256).End(xlToLeft).Column
           If Cells(i, j) <> "" And WorksheetFunction.CountIf(Range("A" & i & ":IV" & i), Cells(i, j)) > 1 And Not d.exists(Cells(i, j).Value) Then
              d.Add Cells(i, j).Value, ""
           End If
     Next j
     Rows(i).ClearContents
     If d.Count > 0 Then Cells(i, 1).Resize(, d.Count) = d.keys
     Set d = Nothing
Next i
End Sub

追问

请问哪个是范围(如:B5:J11)

追答

我这范围是针对你的所有数据
范围你可以自己改FOR循环。
for i= 5 to 11 '5到11行
for j=2 to 10 '从B列到J列

追问

可不可以改成同行内容相同4个以上的才保留
像上图B最多才3个,如果是4个以上的话就保留

追答

关键在countif这里。这里是计数功能。你改成>3
如果不包括4个，就>4

追问

If d.Count > 0 Then Cells(i, 1).Resize(, d.Count) = d.keys
Set d = Nothing
Next i
End Sub
是这样修改吗?好像数据不是直接删除 (接上面补充)

追答Sub a()
Dim d As Object  '定义变量
Dim i%, j%
For i = 5 To 11
     Set d = CreateObject("Scripting.Dictionary") '创建数据字典
     For j = 2 To 10
           ‘这句是判断在该行中有多少个这个数。
           If Cells(i, j) <> "" And WorksheetFunction.CountIf(Range("A" & i & ":IV" & i), Cells(i, j)) > 3 And Not d.exists(Cells(i, j).Value) Then
              d.Add Cells(i, j).Value, ""
           End If
     Next j
     Rows(i).ClearContents
     If d.Count > 0 Then Cells(i, 1).Resize(, d.Count) = d.keys
     Set d = Nothing
Next i
End Sub

追问

还是不对,是在原数据删除
不是将结果移到另单元

追答

到底是想要什么效果。是删除内容，让单元格空起？给一个初始图和效果图来看看。

追问

直接在原数据删除,余下的4个以上单元内容相同的保留不删除

像图片所不:A和C删除,面B为保留

本回答被提问者采纳