Option Explicit
Sub MegaArray()
    Dim Base() As Variant, Base2() As Variant
    Dim TimeS As Variant, TimeE As Variant
    Base = ActiveSheet.Cells(1, 1).Resize(600000, 1).Value
    Base2 = Base
    TimeS = Time
    Debug.Print "CollectionUniq start:   " & UBound(Base) & " " & Date & " " & TimeS
    CollectionUniq Base
    TimeE = Time
    Debug.Print "CollectionUniq end: " & UBound(Base) + 1 & " " & Date & " " & TimeE
    TimeS = Time
    Debug.Print "DictionaryUniq start:   " & UBound(Base2) & " " & Date & " " & TimeS
    DictionaryUniq Base2
    TimeE = Time
    Debug.Print "DictionaryUniq end: " & UBound(Base2) + 1 & " " & Date & " " & TimeE
    
End Sub
Public Sub CollectionUniq(ByRef StringArray() As Variant)
  Dim x, y, arr, i As Long
  
  ReDim arr(LBound(StringArray) To UBound(StringArray))
  arr = StringArray
  If IsArray(arr) Then
    ReDim y(0 To UBound(arr))
    With New Collection
      On Error Resume Next
      For Each x In arr
        If Len(x) > 0 Then
          Err.Clear
          .Add 0, CStr(x)
          If Err = 0 Then
            y(i) = x
            i = i + 1
          End If
        End If
      Next
    End With
  End If
  
  If y(i) = Empty Then
  ReDim Preserve y(0 To i - 1)
  End If
StringArray = y
End Sub
Public Sub DictionaryUniq(ByRef StringArray() As Variant)
  Dim x, arr, y, i As Long
  Dim Uniq_1D_Array() As Variant
  ReDim arr(LBound(StringArray) To UBound(StringArray))
  arr = StringArray
  
  If IsArray(arr) Then
    'With CreateObject("Scripting.Dictionary") ' Позднее связывание
    With New Dictionary ' Раннее связывание, нужен Reference на MS Scripting Runtime
      .CompareMode = vbTextCompare
      ReDim y(0 To UBound(arr))
      For Each x In arr
        If Len(x) > 0 Then
          If Not .Exists(x) Then
            .Add x, 0
            i = i + 1
            y(i) = x
          End If
        End If
      Next
      Uniq_1D_Array = .Keys  ' так можно получить сразу весь массив уникальных
    End With
  End If
  
StringArray = Uniq_1D_Array
End Sub

(ВПР(types_names!$B4;types_names!$A:$D;4;0))

Sub TownOpen()
Dim i As Long
Dim j As Long
Dim k As Integer
Dim l As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Dim a(), z As Long, ii As Long, x As Byte, tmp As String
Set sh = Workbooks("open_file.xlsm").Worksheets("one")
    iLastRow = sh.Cells(Rows.Count, "A").End(xlUp).Row
 folder = Workbooks("open_file.xlsm").Worksheets("two").Cells(1, 1)
 fway = Dir(folder + "*.xls*")
 While fway <> ""
 Workbooks.Open(Filename:=folder + fway).RunAutoMacros Which:= _
  xlAutoOpen
With ActiveWorkbook.Sheets(1)
  For i = 1 To iLastRow
    Set FoundCell = .Columns(3).Find(sh.Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address
        n = 1
      Do
      j = j + 1
        Workbooks("open_file.xlsm").Worksheets("three").Cells(j, n) = sh.Cells(i, "A")
        Workbooks("open_file.xlsm").Worksheets("three").Cells(j, n + 1) = Cells(FoundCell.Row, "B")
        Set FoundCell = .Columns(3).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
     Next
 End With
 ActiveWorkbook.Close
 
   a = Workbooks("open_file.xlsm").Worksheets("three").[a1].CurrentRegion.Value
   ReDim b(1 To UBound(a), 1 To 2)
   With CreateObject("Scripting.Dictionary")
   
        For z = 1 To UBound(a)
           tmp = a(z, 1) & "|" & a(z, 2)
           If Not .exists(tmp) Then
               .Item(tmp) = vbNullString
               ii = ii + 1
               For x = 1 To 2: b(ii, x) = a(z, x): Next
           End If
       Next
   End With
  
   Workbooks("open_file.xlsm").Worksheets("three").[a1].Resize(ii, 2) = b
 fway = Dir()
 Wend
 
End Sub

a = Workbooks("open_file.xlsm").Worksheets("three").[a1].CurrentRegion.Value

Sub TownOpen()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
Dim FoundCell As Range
Dim FAdr As String
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("B2:I" & iLastRow).ClearContents
    FilePath = Sheets("Лист2").Cells(1, 1)
    Workbooks.Open Filename:=FilePath
 With Workbooks("cities.xlsx").Worksheets("cities")
  For i = 2 To iLastRow
    Set FoundCell = .Columns(3).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address
        n = 2
      Do
        Cells(i, n) = Cells(i, "A")
        Cells(i, n + 1) = .Cells(FoundCell.Row, "B")
        Set FoundCell = .Columns(3).FindNext(FoundCell)
        n = n + 2
      Loop While FoundCell.Address <> FAdr
     End If
     Next
 End With
End Sub

 With Workbooks("cities.xlsx").Worksheets("cities")

With Worksheets("source")
 
  For i = 2 To iLastRow
    Set FoundCell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
        n = 2
      Do
       Cells(i, n + 1) = .Cells(FoundCell.Row, "B")
       Set FoundCell = .Columns(1).FindNext(FoundCell)
       n = n + 2
       
       Loop While FoundCell.Address <> FAdr
       End If
     Next
 End With

  With Worksheets("source")
  
  For i = 2 To iLastRow
    Set FoundCell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
        n = 2
      Do
       Cells(i, n) = .Cells(FoundCell.Row, "A")
       Set FoundCell = .Columns(1).FindNext(FoundCell)
       n = n + 2
        Loop While FoundCell.Address <> FAdr
       End If
  Next
 End With

Sub Town()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
Dim FoundCell As Range
Dim FAdr As String
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("B2:I" & iLastRow).ClearContents
   
 With Worksheets("source")
 
  For i = 2 To iLastRow
    Set FoundCell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
        n = 2
      Do
       Cells(i, n + 1) = .Cells(FoundCell.Row, "B")
       Set FoundCell = .Columns(1).FindNext(FoundCell)
       n = n + 2
       
       Loop While FoundCell.Address <> FAdr
       End If
     Next
 End With
 
  With Worksheets("source")
  
  For i = 2 To iLastRow
    Set FoundCell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
        n = 2
      Do
       Cells(i, n) = .Cells(FoundCell.Row, "A")
       Set FoundCell = .Columns(1).FindNext(FoundCell)
       n = n + 2
        Loop While FoundCell.Address <> FAdr
       End If
  Next
 End With
 
End Sub

=СЧЁТЕСЛИ(A$1:A$100;"<56")

=СУММПРОИЗВ(($A$4:$A$9=$A10)*($B$1:$G$1=B$10)*($B$2:$G$2=С$10)*($B$3:$G$3=D$10)*$B$4:$G$9))

='10.05.2017_SONY'!A1

='A1&"_"&A2'!A1

=NSub(A8;$D$8:$E$10;1;2;signs:signs!A1:A21)

=A1