与指定行对比重复个数

vic9

hzg312 发表于 2020-6-12 13:35
第一种情况：“对比”表增加15列数据（截至到AH列），其它不变。

第二种：
Sub jooo试改()
Dim i, r, j, Arr1, Arr2, Arr3, d(39), n, k, m
Arr1 = Sheets("数据").Range("a1:f" & Sheets("数据").Cells(Rows.Count, 1).End(xlUp).Row)
Arr2 = Sheets("对比").Range("a1:ah" & Sheets("对比").Cells(Rows.Count, 1).End(xlUp).Row)
Arr3 = Sheets("结果").Range("a1:ao" & Sheets("结果").Cells(Rows.Count, 1).End(xlUp).Row)
m = 1
For i = 0 To 39
    Set d(i) = CreateObject("scripting.dictionary")
Next

For r = 3 To UBound(Arr2)
    For i = 2 To UBound(Arr2, 2)
        If Len(Arr2(r, i)) > 0 Then
            d(r - 3)(Arr2(r, i)) = ""
        End If
    Next
Next

For i = 3 To UBound(Arr1)
    For j = 0 To 39
        For r = 2 To UBound(Arr1, 2)
            If d(j).exists(Arr1(i, r)) Then
                k = k + 1
            End If
        Next
         m = m + 1
        Arr3(i, m) = k
        k = 0
    Next
    m = 1
Next

Sheets("结果").[a1].Resize(UBound(Arr3), UBound(Arr3, 2)) = Arr3
End Sub