给每个独特的价值赋予独特的参考
我有一个Excel表有一些重复，我们目前有一个计数，但是我想填充每个重复的唯一编号。 例如
Number Count Sequence 1 2 1 1 2 1 2 3 2 2 3 2 2 3 2 3 4 3 3 4 3 3 4 3 3 4 3 4 2 4 4 2 4 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 我正在玩下面的IF声明，但我希望它能检查整个范围，并检查它是否有错误的顺序，但仍然是一样的。
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
这可能吗？
它将添加独特的参考列是从你设置的每一个col等于3列。
它还要求col + 3是空白的，这将使检查更容易。
Sub SomeSub() Dim Array1 As Variant Dim Array2 As Variant With ActiveSheet.UsedRange LastRow = .Rows(.Rows.Count).Row End With 'Setting up the array for assigning each row value to the array ReDim Array1((LastRow + 1)) ReDim Array2((LastRow + 1)) 'Here youwill set what column is the "Number" Column col = 1 'Assigning the row data into the arrays 'Starting at 2 to skip the title row For r = 2 To LastRow 'Values in Column 1 go to Array1 Array1(r) = Cells(r, col) 'Values in Column 2 go to Array2 Array2(r) = Cells(r, col + 1) Next r 'Setting unquie ref to 1 Seq = 1 'Running through each row of data For i = 2 To LastRow 'col + 3 refers to a column on beyond the Sequence colum 'If the column is blank then that row has not been checked yet If Cells(i, col + 3) = "" Then 'Assign the Uniqui ref to the row Cells(i, col + 3).Value = Seq 'Running through the rest of the rows to check if they are like the current row For n = i + 1 To (LastRow) 'If cell is blank then the row has been checked If Cells(n, col + 3) = "" Then 'Array(i) is the current row 'Array(n) are the leading rows after row i 'If the current row is the same as any leading row then the uniquie ref = seq If Array1(i) = Array1(n) And Array2(i) = Array2(n) Then Cells(n, col + 3).Value = Seq 'Else a value has been added Else 'Do nothing End If Next n 'Increment the seq Seq = Seq + 1 'Ending the If Cells(i, col + 3) = "" Then End If Next i End Sub
您可以先循环访问该列，然后使用集合获取唯一的项目。
这部分代码：
On Error Resume Next For Each Cell In Rng.Cells cUnique.Add Cell.Value, CStr(Cell.Value) Next Cell
只会得到独特的项目，因为一个项目的集合不能有重复。
使用它来为重复号码编号。根据需要更改表格名称。
Sub NumberDupes() Dim cUnique As Collection Dim Rng As Range Dim Cell As Range Dim sh As Worksheet Dim vNum As Variant Dim LstRw As Long Dim c As Long, clr As Long, x, r As Range Set sh = Sheets("Sheet2") With sh .Columns("B:B").ClearContents LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1)) Set cUnique = New Collection Rng.Interior.ColorIndex = xlNone clr = 1 On Error Resume Next For Each Cell In Rng.Cells cUnique.Add Cell.Value, CStr(Cell.Value) Next Cell On Error GoTo 0 For Each vNum In cUnique For c = 1 To LstRw Set r = .Cells(c, 1) x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r) If r = vNum Then If x > 1 Then r.Offset(, 1) = clr End If End If Next c clr = clr + 1 Next vNum End With End Sub
使用这个来重复颜色，这将工作在一个小规模，取决于有多less独特的项目，这是很酷的例子。 从我的答案编辑代码在这里。
Sub ColorDupes() Dim cUnique As Collection Dim Rng As Range Dim Cell As Range Dim sh As Worksheet Dim vNum As Variant Dim LstRw As Long Dim c As Long, clr As Long, x, r As Range Set sh = Sheets("Sheet2") With sh LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1)) Set cUnique = New Collection Rng.Interior.ColorIndex = xlNone clr = 3 On Error Resume Next For Each Cell In Rng.Cells cUnique.Add Cell.Value, CStr(Cell.Value) Next Cell On Error GoTo 0 For Each vNum In cUnique For c = 1 To LstRw Set r = .Cells(c, 1) x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r) If r = vNum Then If x > 1 Then r.Interior.ColorIndex = clr End If End If Next c clr = clr + 1 Next vNum End With End Sub
在C1只有1和C2 ：
=MIN(IF(($A$2:A2=A3)*($B$2:B2=B3),$D$2:D2,MAX($D$2:D2)+1))
这是一个数组公式，并且必须用Ctrl + Shift + Enter确认 。
并从C3自动填充
嗯…我想我错了：/
如果只看A列，那么这应该足够了：
=MIN(IF($A$2:A2=A3,$D$2:D2,MAX($D$2:D2)+1))
这是一个数组公式，并且必须用Ctrl + Shift + Enter确认 。
看你的公式可以缩短：
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)) 'IF(A2=A1,TRUE,FALSE)=FALSE ==>> A1<>A2 =IF(IF(A1<>A2,1,0)>=0,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0)) 'IF(A1<>A2,1,0)>=0 ==>> TRUE =IF(TRUE,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0)) 'IF(TRUE => allways true =IF(A1<>A2,1,0)+D1 'last skip =D1+(A1<>A2)