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

以A1：E4区域为例，代码如下：

Sub tst()
Dim i%, j%, k%
 For i = 1 To 4
  For j = 0 To 4
   For k = 0 To 4
    If Cells(i, 1)Offset(0, j)Value = Cells(i, 1)Offset(0, k)Value And j <> k Then Cells(i, 1)InteriorColorIndex = i + 10
   Next
  Next
 Next
End Sub

或者下面代码也可以，

Sub tst()
Dim d As Object  '定义变量
Dim i%, j%
For i = 1 To [a65536]End(3)Row
     Set d = CreateObject("ScriptingDictionary") '创建数据字典
     For j = 1 To Cells(i, 256)End(xlToLeft)Column
           If Cells(i, j) <> "" And WorksheetFunctionCountIf(Range("A" & i & ":IV" & i), Cells(i, j)) > 1 And Not dexists(Cells(i, j)Value) Then
              dAdd Cells(i, j)Value, ""
           End If
     Next j
     Rows(i)ClearContents
     If dCount > 0 Then Cells(i, 1)Resize(, dCount) = dkeys
     Set d = Nothing
Next i
End Sub

代码如下：

Sub a()
Dim i%, j%, k%
k = 1
For i = 1 To 3
    For j = 1 To Cells(65536, i)End(xlUp)Row
         If WorksheetFunctionCountIf(Range("A:A"), Cells(j, i)) > 0 And _
            WorksheetFunctionCountIf(Range("b:b"), Cells(j, i)) > 0 And _
            WorksheetFunctionCountIf(Range("c:c"), Cells(j, i)) > 0 And _
            WorksheetFunctionCountIf(Range("d:d"), Cells(j, i)) = 0 Then
            Cells(k, 4) = Cells(j, i)
            k = k + 1
         End If
    Next j
Next i
End Sub

其实3列都同时存在的数。可以不用循环找3次。上面的代码都多余了。

改为如下：

Sub a()
Dim i%, j%, k%
k = 1
    For j = 1 To [a65536]End(xlUp)Row
         If WorksheetFunctionCountIf(Range("A:A"), Cells(j, 1)) > 0 And _
            WorksheetFunctionCountIf(Range("b:b"), Cells(j, 1)) > 0 And _
            WorksheetFunctionCountIf(Range("c:c"), Cells(j, 1)) > 0 And _
            WorksheetFunctionCountIf(Range("d:d"), Cells(j, 1)) = 0 Then
            Cells(k, 4) = Cells(j, 1)
            k = k + 1
         End If
    Next j
End Sub

Private Sub CommandButton1_Click()
Dim BmCell As Range
If TextBox1Value = "" Then
MsgBox "请输入所要查询的编码"
Exit Sub
End If
With Worksheets("刀具信息")
textbox11value = ""
For Each BmCell In Range("L2:L" & Range("l65536")End(xlUp)Row)
If CStr(BmCell) = TextBox1Value Then
'下一行if判断中返回查到相同编码的单元格地址如果有多个单元格地址用","隔开
If textbox11Value = "" Then
textbox11Value = BmCellAddress(0, 0)
Else
textbox11Value = textbox11Value & "," & BmCellAddress(0, 0)
End If
End If
Next
End With
End Sub

Sub 判断并生成新表()
    Dim countCells, x As Long
    Dim rg As Range
    Dim wst As Worksheet
    Dim str As String
    
    '常量命名
    Set wst = Sheets("旧表")
    Set rg = wstRange("a1:b1")
    
    '新表名称str
    nowTime = Format(Time, "hhmmss")
    str = "新表" & nowTime
    
    '统计A列单元格个数，确定循环次数
    countCells = ApplicationWorksheetFunctionCountA(wstRange("a:a"))
    
    'FOR循环
    For x = 2 To countCells
        If wstRange("a" & x)Value = wstRange("b" & x)Value Then
            Set rg = Union(rg, wstRange("a" & x & ":b" & x))   '注意这里面必须有Set,否则会出错
        End If
    Next
    
    SheetsAddName = str   '新建表格，并命名为新表
    rgCopy Sheets(str)Range("a1")     '将符合条件的内容粘贴至新表
End Sub

字典最合适，代码如下：
Sub AA()
arr = Range("B2:B10")
Set d = CreateObject("scriptingdictionary")
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next
[C2]Resize(dCount) = ApplicationTranspose(dkeys)
Set d = Nothing
End Sub

---