请改公式为vba代码

lrh788

请帮忙将下面两个公式改写成代码
第一个公式:
=SUMPRODUCT((A1&B1=A$1:A$800000&B$1:B$800000)*1)第一个公式的代码己完成。谢谢各位大神的帮助！
第二个公式:（附件在22楼）
=LEFT(MID(A2,MIN(FIND({"区","市","县"},A2&"区市县"))+1,20),MAX(IFERROR(FIND({"区","镇","村","办","道"},MID(A2,MIN(FIND({"区","市","县"},A2&"区市县"))+1,20)),)))
请各位老师帮忙把上面数组公式改写成代码！我的数据有70多万条，数组公式运行很慢！（22楼附件中有两个公式，运行结果一样）第三个公式：
=IF(OR(A2="",B2=""),"",IF(A2=B2,"相同",IF(COUNT(0/COUNTIF(B2,"*"&MID(A2,ROW($1:$9),1)&"*")/(MID(A2,ROW($1:$9),1)<>"")),"相似","不同")))

请各位老师再次帮忙把上面数组公式改写成代码！

zhangzhang

还是有 附件 比较好。。。。。。。

lrh788

zhangzhang 发表于 2018-5-23 20:54
还是有 附件 比较好。。。。。。。

此公式就是查找符合A1与B1双条件在A、B列中重复出现的次数？以下依此类推！

zhangzhang

详见附件。。。。。。。。。。。

lrh788

zhangzhang 发表于 2018-5-23 21:32
详见附件。。。。。。。。。。。

Public Sub test()
Dim Arr
Dim i As Long, m As Long
Dim Str

Arr = Range("A1").CurrentRegion
Str = Arr(1, 1) & Arr(1, 2)
m = 1

For i = 2 To UBound(Arr)
    If Arr(i, 1) & Arr(i, 2) = Str Then
        m = m + 1
    End If
Next i

Range("D1") = m



End Sub

如何修改代码在D列把所有重复数据的重复次数都依次显示出来

zhangzhang

lrh788 发表于 2018-5-23 21:36
Public Sub test()
Dim Arr
Dim i As Long, m As Long

Public Sub test()
Dim Arr
Dim i As Long
Dim Dic As Object

Set Dic = CreateObject("Scripting.Dictionary")

Arr = Range("A1").CurrentRegion


For i = 1 To UBound(Arr)
    Dic(Arr(i, 1) & Arr(i, 2)) = Dic(Arr(i, 1) & Arr(i, 2)) + 1
Next i

Range("D2").Resize(Dic.Count, 2) = Application.Transpose(Array(Dic.keys, Dic.items))

Set Dic = Nothing
Set Arr = Nothing

End Sub

lrh788

zhangzhang 发表于 2018-5-23 21:47
Public Sub test()
Dim Arr
Dim i As Long

AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4
AAA4        BBB4        4
AAA5        BBB5        4
AAA6        BBB6        4
AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4
AAA4        BBB4        4
AAA5        BBB5        4
AAA6        BBB6        4
AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4
AAA4        BBB4        4
AAA5        BBB5        4
AAA6        BBB6        4
AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4
AAA4        BBB4        4
AAA5        BBB5        4
AAA6        BBB6        4
我的意图是这样显示

zhangzhang

lrh788 发表于 2018-5-23 21:49
AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4

Public Sub test()
Dim Arr, Spt, K, T
Dim i As Long
Dim Dic As Object

Set Dic = CreateObject("Scripting.Dictionary")

Arr = Range("A1").CurrentRegion


For i = 1 To UBound(Arr)
    Dic(Arr(i, 1) & " " & Arr(i, 2)) = Dic(Arr(i, 1) & " " & Arr(i, 2)) + 1
Next i
K = Dic.keys
T = Dic.items
ReDim Arr(1 To Dic.Count, 1 To 3)

For i = 1 To UBound(Arr)
    Spt = VBA.Split(K(i - 1), " ")
    Arr(i, 1) = Spt(0)
    Arr(i, 2) = Spt(1)
    Arr(i, 3) = T(i - 1)
Next i

Range("D2").Resize(UBound(Arr), 3) = Arr

Set Dic = Nothing
Set Arr = Nothing

End Sub

zhangzhang

如果 有附件， 一次就能够说清楚。

lrh788

zhangzhang 发表于 2018-5-23 21:59
Public Sub test()
Dim Arr, Spt, K, T
Dim i As Long

我的意思是在c列直接把所有重复数据的重复次数都依次显示出来
AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4
AAA4        BBB4        4
AAA5        BBB5        4
AAA6        BBB6        4
AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4
AAA4        BBB4        4
AAA5        BBB5        4
AAA6        BBB6        4
AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4
AAA4        BBB4        4
AAA5        BBB5        4
AAA6        BBB6        4
AAA1        BBB1        4
AAA2        BBB2        4
AAA3        BBB3        4
AAA4        BBB4        4
AAA5        BBB5        4
AAA6        BBB6        4