比较工作表中的两行，并测试每一行的唯一值和列中的输出

Question

我有一个工作表，其中有两个具有不同值的列，即病人ID (ID#)和研究所。

我希望在对应于每个单元格的不同列中找到这两列之间的唯一值，并将输出作为1(是唯一的)和0(不唯一)。

我需要使用Array，因为我在每一列中有10,000条记录要测试。

试验条件：

案例1: PatientID in value (A1 = "HC1")转到Institute (B2 = "HG")。这是一个独特的价值，因为PatientID和研究所只出现一次。因此，输出值(C1 = "1")。

案例2: PatientID值(A2 = "HC1")转到Institute (B2 = "HG")。这并不是独一无二的，因为同一个病人又去了同一所医院。因此，输出值(C2 = "0")。

案例3: PatientID值(A3 = "HC1")转到Institute (B3 = "RH")。这是独一无二的，因为同一个病人去的是不同的研究所。因此，输出值(C3 = "1")。

案例4: PatientID值(A4 = "HC2")转到机构值(B4 = "RH")。这是独一无二的，因为不同的病人去的是不同的机构。因此，输出的值应该是值(C4 = "1")。

我需要VB代码来做同样的事情。

目前我使用此Excel 2010公式，

=IF(SUMPRODUCT(($C$2:$C1442=C3)*($A$2:$A1442=A3))>1,0,1)

其中，C列为研究所，A列为PatientID。

这需要大量的时间来计算。请帮帮忙。

谢谢

Answer 1

可以使用助手列将两个单元格组合在一起，然后计算这些单元格是否是唯一的。

​

​

结果

​

​

如果你想要你可以隐藏C列

​

​

Answer 2

如果要使用相同的宏，可以如下所示：

Sub TEST()
Set ExcelAppl = CreateObject("Excel.Application")
Set wb = ActiveWorkbook
Set ActiveRange = wb.Worksheets(1).UsedRange
RowCont = ActiveRange.Rows.Count
Dim dataArr() As Variant
ReDim dataArr(RowCont, 1)
For i = 0 To RowCont - 1
InputText = Cells(i + 1, 1).Value & Cells(i + 1, 2).Value
If CheckUnique(dataArr, InputText) = True Then
Cells(i + 1, 3).Value = 0
Else
Cells(i + 1, 3).Value = 1
dataArr(i, 0) = InputText
dataArr(i, 1) = i + 1 'store row number
End If
Next
End Sub

Function CheckUnique(dataArr, InputText)
Dim lb As Long, ub As Long, i As Long, result As Boolean
lb = LBound(dataArr)
ub = UBound(dataArr)
result = False
For i = lb To ub
If dataArr(i, 0) = InputText Then
result = True
Cells(i + 1, 3).Value = 0
Exit For
End If
Next i
CheckUnique = result
End Function

产出将是：

​

​