Sub iTown()
Dim Rng As Range
Dim iTown As String
Dim iLastRow As Long
  Columns("C").ClearContents
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  For Each Rng In Range("B1:B" & iLastRow).SpecialCells(2, 1).Areas
    iTown = Split(Rng(0, 0), ":")(1)
    Rng.Offset(, 1) = iTown
  Next
End Sub

'добавить строку 1, в А1 вставить слово Адрес
Sub iTownStreet()
Dim Rng As Range
Dim iTown As String
Dim iLastRow As Long
Dim FoundCell_1 As Range
Dim FoundCell_2 As Range
Dim FRow As Long
Dim FAdr As String
Dim ERow As Long
  Columns("C").ClearContents
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  'ищем в столбце А ячейку со словом Город:
Set FoundCell_1 = Columns(1).Find("Город:", , xlValues, xlPart)
   If Not FoundCell_1 Is Nothing Then
     FAdr = FoundCell_1.Address  'адрес первого вхождения
     FRow = FoundCell_1.Row
   Do
      iTown = Split(Cells(FRow, 1), ":")(1)
  'ищем в столбце А ячейку со словом Город: после предыдущего вхождения
      Set FoundCell_2 = Columns(1).Find("Город:", FoundCell_1)
       ERow = FoundCell_2.Row
        If FoundCell_2.Address = FAdr Then ERow = iLastRow
     For Each Rng In Range("B" & FRow & ":B" & ERow - 1).SpecialCells(2, 1).Areas
         Rng.Offset(, 1) = iTown
     Next
       Set FoundCell_1 = Columns(1).Find("Город:", FoundCell_1)
       FRow = FoundCell_1.Row
   Loop While FoundCell_1.Address <> FAdr
  End If
End Sub