Sub fast_count()

Dim ws As Worksheet
Dim EndRow As Long

Set ws = ThisWorkbook.Worksheets("Дубли физ лиц")
Set ID_Dict = CreateObject("Scripting.Dictionary")
Set Identity_Dict = CreateObject("Scripting.Dictionary")

StartTime = Timer
IDColumn = 3
IdentityColumn = 9

EndRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
StartRow = 2

ws.Range("I2:I" & EndRow).Formula = "=CONCAT(D2:G2)"


For i = StartRow To EndRow Step 1
    Identity = Cells(i, IdentityColumn).Value
    If Identity_Dict.Exists(Identity) Then
        Identity_Dict(Identity) = Identity_Dict(Identity) + 1
    Else
        Identity_Dict.Add Identity, 1
    End If
    
    ID = Cells(i, IDColumn).Value
    If ID_Dict.Exists(ID) Then
        ID_Dict(ID) = ID_Dict(ID) + 1
    Else
        ID_Dict.Add ID, 1
    End If
    
Next
          
IDKeys = ID_Dict.keys
IDCount = ID_Dict.items

IdentityKeys = Identity_Dict.keys
IdentityCount = Identity_Dict.items
                    
For j = 2 To EndRow

For i = LBound(IdentityKeys) To UBound(IdentityKeys)

If ws.Cells(j, IdentityColumn).Value = IdentityKeys(i) Then
ws.Cells(j, 10).Value = IdentityCount(i)
Else
End If

Next i

For p = LBound(IDKeys) To UBound(IDKeys)

If ws.Cells(j, IDColumn).Value = IDKeys(p) Then
ws.Cells(j, 11).Value = IDCount(p)
Else
End If
Next p

If ws.Cells(j, 10).Value = ws.Cells(j, 11).Value Then
ws.Cells(j, 12).Value = True
Else
ws.Cells(j, 12).Value = False
End If

Next j
Columns(9).EntireColumn.Delete
MsgBox "Done. ", , Round(Timer - StartTime, 2) & "s"

End Sub

SaveAs name & ".csv", xlCSVUTF8

=Windy.Query("SELECT sum(ID) FROM Таблица1")

Sub collect_info()

Dim ws As Worksheet, LastColumn As Long, LR As Long, LR_ALL As Long, All As Worksheet

Set All = ActiveWorkbook.Worksheets("All")

For Each ws In ActiveWorkbook.Worksheets

If ws.Name = "All" Then
GoTo finish
Else

LastColumn = ws.Cells(11, ws.Columns.Count).End(xlToLeft).Column

LR = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row

LR_ALL = All.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1

ws.Range("B11:C" & LR).Copy _
    Destination:=All.Range("A" & LR_ALL)
End If

For i = 1 To LastColumn

If ws.Cells(1, i).Value = "ПОЛНОЕ НАИМЕНОВАНИЕ" Then

ws.Range(ws.Cells(11, i), ws.Cells(LR, i)).Copy

All.Range("C" & LR_ALL).PasteSpecial xlPasteValues

End If

Next i

finish:
Next

End Sub

https://maps.googleapis.com/maps/api/directions/xml?origin=115533,%D0%9C%D0%BE%D1%81%D0%BA%D0%B2%D0%B0%20%D0%B3,%D0%9D%D0%B0%D0%B3%D0%B0%D1%82%D0%B8%D0%BD%D1%81%D0%BA%D0%B8%D0%B9%20%D0%B1-%D1%80,6%20%D0%90,,&destination=115533,%D0%9C%D0%BE%D1%81%D0%BA%D0%B2%D0%B0%20%D0%B3,%D0%9D%D0%B0%D0%B3%D0%B0%D1%82%D0%B8%D0%BD%D1%81%D0%BA%D0%B0%D1%8F%20%D0%BD%D0%B0%D0%B1,22,%D0%BA%D0%BE%D1%80%D0%BF%202,&mode=driving&language=ru

https://maps.googleapis.com/maps/api/directions/xml?origin="; & Address1 & "&destination=" & Address2 & "&mode=driving&language=ru"