Question

我正在尝试添加excel项目的现有VBA代码。我正在寻找一个VBA来在列中查找重复值，结果将在另一列中打印。例如，如果在一列中输入两次User1，则第二次输入它 - 将会有＆＃34;重复＆＃34;在下一栏。

Sub DuplicateFinder()
    Dim LastRow As Long
    Dim matchFoundIndex As Long
    Dim iCntr As Long
    LastRow = Range("A65000").End(xlUp).Row
    For iCntr = 1 To LastRow
        If Cells(iCntr, 1) <> "" Then
            matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & LastRow), 0)
            If iCntr <> matchFoundIndex Then
                Cells(iCntr, 2) = "Duplicate"
            End If
        End If
    Next
End Sub

是否可以修改它，然后当找到重复时，它将检查另一列是否有两个值之间的差异。

所以，如果我有一个：

 A      |    B    |    C    |    D
 user1                11
 user2                11
 user1    duplicate   12      "error"

我希望宏说出＆＃34;错误＆＃34;如果两个值之间的差值是=＆lt; 6

Answer 1

如果要检查最近一个单元格与匹配项之间的差异是否为＆lt; = 6：

If iCntr <> matchFoundIndex Then
   Cells(iCntr, 2) = "Duplicate"
   If Cells(iCntr, 3) - Cells(matchFoundIndex, 3) <= 6 Then
      Cells(iCntr, 4) = "Error"
   End If
End If

如果你想要绝对差异：

If Abs(Cells(iCntr, 3) - Cells(matchFoundIndex, 3)) <= 6 Then

Answer 2

对于更一般的方法，我会如下：

Option Explicit

Sub DuplicateFinder()
    Dim user As Variant

    With Sheets("duplicates") '<--| change "duplicates" to your actual sheet name
        With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| reference its column A range from row 1 (header) down to the one corresponding to last column A not empty row
            For Each user In GetUsers(.Resize(.Rows.Count - 1).Offset(1)) '<-- get unique users starting from 2nd row downwards and loop through them
                If Application.WorksheetFunction.CountIf(.Cells, user) > 1 Then HandleUser .Cells, user '<--| if more then one current user occurrences then "handle" it
            Next
        End With
        .AutoFilterMode = False
    End With
End Sub

Sub HandleUser(rng As Range, user As Variant)
    Dim cell As Range
    Dim iCell As Long, refvalue As Long

    With rng
        .AutoFilter Field:=1, Criteria1:=user '<--| filter column A cells with current 'user'
        With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<-- reference filtered cells, skippinh headers
            refvalue = .Cells(, 2).Value '<--| retrieve first occurrence value from cell two columns to the right
            For Each cell In .Cells '<--| loop through filtered cells
                If iCell > 0 Then '<--| start handling occurrences form the 2nd one on
                    cell.Offset(, 1) = "Duplicate" '<--| mark it as duplicate
                    If cell.Offset(, 2) - refvalue > 6 Then cell.Offset(, 3) = "error" '<--| place "error" if two cells to the right from current 'user' has a value greater then first occurrence value + 6
                End If
                iCell = iCell + 1 '<--| update user occurrences counter
            Next
        End With
    End With
End Sub

Function GetUsers(rng As Range) As Variant
    Dim cell As Range
    With CreateObject("Scripting.Dictionary")
        For Each cell In rng
            .Item(cell.Value) = cell.Value
        Next cell
        GetUsers = .keys
    End With
End Function

VBA宏优于，根据前一个变量计算两个值之间的差异

2 个答案: