Слипшийся текст, как разделить?

[zvmofficial]

Здравствуйте. На форуме уже нашел подобный вопрос, правда там были значения на английском, но у меня не работает то решение. Макрос выполняется, но текст не хочет делить, просто дублирует. Вот ссылка, где нашел http://www.programmersforum.ru/showthread.php?t=94344

Дано (часть из файлика скопировал):

Промышленный дизайн
Земляные работыБуровые работы
Земляные работыБуровые работыСвайные работы
Земляные работы
Услуги грузчиковТакелажные работыВывоз мусораРемонт и отделка помещенийЗемляные работы
Строительство многоквартирных домовЗемляные работы
Строительство административных зданийРеконструкция и капремонт зданийСнос зданий и сооруженийСвайные работыЗемляные работы
Земляные работы
Земляные работыОбслуживание наружных систем отопления, водоснабжения, канализацииВывоз мусора
Земляные работыСтроительство дач и коттеджей
Земляные работы
Услуги грузчиковЗемляные работыБлагоустройство улиц
Земляные работыРемонт дорог
Земляные работы
Услуги грузчиковВывоз мусораЗемляные работыТакелажные работы
Земляные работыСнос зданий и сооруженийСвайные работы
Земляные работы
Земляные работы
Ремонт и отделка помещенийСтроительство дач и коттеджейЗемляные работыФасадные работы
Строительство фундаментаСвайные работыЗемляные работы
Земляные работыБуровые работыАлмазное бурение и резкаСвайные работы
Земляные работыСвайные работыСтроительство фундамента
Ландшафтная архитектураЗемляные работы

Задача:

Разделить слипшийся текст по отдельным столбцам. Заглавная буква получается и есть разделитель, только вот какой формулой это можно разделить?

Кто может подсказать, большое спасибо!

[svsh2016]

вариант макроса,кнопки test и очистка в столбце K

Sub test()
Dim i&, j&, t$
With CreateObject("VBScript.RegExp"): .Pattern = "[А-ЯЁ][^А-ЯЁ]+": .Global = True
 For j = 1 To Range("A" & Rows.Count).End(xlUp).Row: t = Range("A" & j)
   For i = 0 To .Execute(t).Count - 1: Range("B" & j).Offset(, i) = .Execute(t)(i)
   Next i, j
  End With
  Columns("B:F").AutoFit
End Sub

[svsh2016]

в предыдущем сообщении не загрузился файл-пример

Sub очистка()
test
Dim t1$: t1 = Split(Range("A1").CurrentRegion.Address, "$")(3)
Range("B1:" & t1 & Range("B" & Rows.Count).End(xlUp).Row).ClearContents
End Sub

[Казанский]

как вариант

Sub bb()
Dim i&
  Application.ScreenUpdating = False
  With Range("A:A")
    For i = Asc("А") To Asc("Я")
      .Replace Chr$(i), "$" & Chr$(i), xlPart, , True
    Next
    .TextToColumns Range("A1"), Other:=True, OtherChar:="$"
    .Delete
  End With
  Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

[zvmofficial]

Сообщение от svsh2016

вариант макроса,кнопки test и очистка в столбце K

Sub test()
Dim i&, j&, t$
With CreateObject("VBScript.RegExp"): .Pattern = "[А-ЯЁ][^А-ЯЁ]+": .Global = True
 For j = 1 To Range("A" & Rows.Count).End(xlUp).Row: t = Range("A" & j)
   For i = 0 To .Execute(t).Count - 1: Range("B" & j).Offset(, i) = .Execute(t)(i)
   Next i, j
  End With
  Columns("B:F").AutoFit
End Sub

Что-то не получается. Просто ничего не происходит при запуске макроса.

Сообщение от svsh2016

в предыдущем сообщении не загрузился файл-пример

Sub очистка()
test
Dim t1$: t1 = Split(Range("A1").CurrentRegion.Address, "$")(3)
Range("B1:" & t1 & Range("B" & Rows.Count).End(xlUp).Row).ClearContents
End Sub

PS файлик-пример так и не загрузился.

Сообщение от Казанский

как вариант

Sub bb()
Dim i&
  Application.ScreenUpdating = False
  With Range("A:A")
    For i = Asc("А") To Asc("Я")
      .Replace Chr$(i), "$" & Chr$(i), xlPart, , True
    Next
    .TextToColumns Range("A1"), Other:=True, OtherChar:="$"
    .Delete
  End With
  Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

Запустил получил миллион вопросительных знаков и мелкие ячейки))

[Aleksandr H.]

Сообщение от zvmofficial

Запустил получил миллион вопросительных знаков и мелкие ячейки))

пробуйте еще. Код отрабатывает отлично на тестовом наборе

[svsh2016]

файл-пример,все работает

[zvmofficial]

У меня не сработал не один вариант. Выкладываю рабочий вариант (который у меня сработал). Всем спасибо за отклики!

[svsh2016]

доброй ночи,Вы фактически изменили файл-пример,вот вариант для Вашего последнего файл-примера,кнопки test2 и очистка в строке 18

Sub test2()
Dim i&, j&, t$, O As Object
With CreateObject("VBScript.RegExp"): .Pattern = "[А-ЯЁ][^А-ЯЁ]+": .Global = True
 For j = 1 To Range("A" & Rows.Count).End(xlUp).Row: t = Range("A" & j): Set O = .Execute(t)
   For i = 0 To O.Count - 1
   If .test(t) Then Range("B" & j).Offset(, i) = O(i)
   Next
   Next
  End With
  Columns("B:F").AutoFit
End Sub

[zvmofficial]

Сообщение от svsh2016

доброй ночи,Вы фактически изменили файл-пример,вот вариант для Вашего последнего файл-примера,кнопки test2 и очистка в строке 18

Sub test2()
Dim i&, j&, t$, O As Object
With CreateObject("VBScript.RegExp"): .Pattern = "[А-ЯЁ][^А-ЯЁ]+": .Global = True
 For j = 1 To Range("A" & Rows.Count).End(xlUp).Row: t = Range("A" & j): Set O = .Execute(t)
   For i = 0 To O.Count - 1
   If .test(t) Then Range("B" & j).Offset(, i) = O(i)
   Next
   Next
  End With
  Columns("B:F").AutoFit
End Sub

Скорее всего Вы правы, потому как не я автор файлика, но все равно скинул в тему, мало ли кому пригодится и этот вариант, ведь у меня другие варианты почему-то не срабатывали.