Option Explicit

Private Type MyType
         Firm As String
         Adr As String
         Pho As String
         Mail As String
         Http As String
End Type

Sub tt()
         Dim a(), c() As MyType, i&, j&
         On Error Resume Next
         a = Sheets("Лист1").[a1].CurrentRegion.Value
         For i = 1 To UBound(a)
             If InStr(a(i, 1), "Назва:") Then
                 j = j + 1
                 ReDim Preserve c(1 To j)
                 With c(j)
                     .Firm = a(i + 1, 1)
                     .Adr = a(i + 3, 1)
                     .Pho = a(i + 5, 1)
                     .Mail = a(i + 7, 1)
                     .Http = a(i + 9, 1)
                 End With
             End If
         Next

         ReDim arrOut(1 To j, 1 To 5)    ' итоговый массив
         For i = 1 To j    'перекладываем из одного в другое...
             With c(i)
                 arrOut(i, 1) = .Firm
                 arrOut(i, 2) = .Adr
                 arrOut(i, 3) = .Pho
                 arrOut(i, 4) = .Mail
                 arrOut(i, 5) = .Http
             End With
         Next i

         With ThisWorkbook.Sheets("Лист2")    'выгрузка
             .Cells.Clear
             .[a1].Resize(, 5).Value = Split("Название Адрес Телефон Mail Http")
             .[a2].Resize(j, 5).Value = arrOut
             .Activate
         End With

End Sub