Разделение слитного написания в ячейке с разным регистром

[SAUUNSAPR]

Добрый день, уважаемые знатоки Excel. Помогите решить проблему. В одной ячейке введены данные, например: "ИвановИванИванович начальник отдела". А нужно, что бы в данной ячейке или в соседней ФИО было написано все раздельно, например: "Иванов Иван Иванович начальник отдела". Можно было бы и вручную, но когда таких записей несколько тысяч?! Реально ли это сделать формулой или в коде. Спасибо.

[Aleksandr H.]

v.1

Sub splitFIO()
    Dim FIO$, uFIO$, newFIO$
    Dim i As Byte
    FIO = "ИвановИвaнИванович начальник отдела"
    uFIO = UCase(FIO)
    newFIO = Mid(FIO, 1, 1)
    For i = 2 To Len(FIO)
        If Mid(FIO, i, 1) = Mid(uFIO, i, 1) Then
            newFIO = newFIO & " " & Mid(FIO, i, 1)
        Else
            newFIO = newFIO & Mid(FIO, i, 1)
        End If
    Next
    MsgBox (FIO & Chr(13) & newFIO)
End Sub

v.2

Function splitFIO(cel As Range)
    Dim FIO$, uFIO$, newFIO$
    Dim i As Byte
    FIO = cel.Cells(1, 1).Value2
    uFIO = UCase(FIO)
    newFIO = Mid(FIO, 1, 1)
    For i = 2 To Len(FIO)
        If Mid(FIO, i, 1) = Mid(uFIO, i, 1) Then
            newFIO = newFIO & " " & Mid(FIO, i, 1)
        Else
            newFIO = newFIO & Mid(FIO, i, 1)
        End If
    Next
    splitFIO = newFIO
End Function

[SAUUNSAPR]

Спасибо Александр! Но весь смысл в том что в базе данный в ячейках по этому столбцу могут быть разные записи, не только "ИвановИИ", а все что угодно работники напишут, а для дальнейшей обработки данных нужно "подчистить" все эти "глюки" и уже работать с текстом, но не на красивой форме выводимой, а новый текст должен попасть в соседнюю ячейку.

[svsh2016]

добрый день,еще вариант макроса,кнопка test

 Sub test()
   Dim t$, i&, j&, i1&, t1$, m&
 For j = 1 To Range("A" & Rows.Count).End(xlUp).Row: m = 0
   t = Range("A" & j)
   For i = 2 To Len(t)
     If Mid(t, i, 1) Like "[А-ЯЁ]" Then
       m = m + 1
       If m = 1 Then i1 = i: t1 = Left(t, i - 1)
       If m = 2 Then Range("C" & j) = t1 & Chr(32) & Mid(t, i1, i - i1) & Chr(32) & Mid(t, i)
     End If
   Next i, j
End Sub

[SAUUNSAPR]

Спасибо, оригинально, но вот после ФИО, что то не разделяет дальше, а ведь могут ФИО правильно написать, а вот в должности или другом тексте после ФИО слитно что-то записать, как дальше то делить. И самое главное хотелось бы в виде формулы это получить или функцией прописать, что бы потом на листе протянуть это на всю БД, спасибо!

[Aleksandr H.]

код v.2 пробовали? Там ведь фукнция

Function splitFIO(cel As Range)
    Dim FIO$, uFIO$, newFIO$
    Dim i As Byte
    FIO = cel.Cells(1, 1).Value2
    uFIO = UCase(FIO)
    newFIO = Mid(FIO, 1, 1)
    For i = 2 To Len(FIO)
        If Mid(FIO, i, 1) = Mid(uFIO, i, 1) Then
            newFIO = newFIO & " " & Mid(FIO, i, 1)
        Else
            newFIO = newFIO & Mid(FIO, i, 1)
        End If
    Next
    splitFIO = Application.Trim(newFIO)
End Function

ps а вот ОЦОР вабше не в тему

[SAUUNSAPR]

Александр Спасибо все замечательно работает 2 вариант с функцией, сейчас только увидел, как зашел на форум. Всем тоже спасибо!

[svsh2016]

SAUUNSAPR,вариант test2 со считыванием в массив,протягивать не надо
диапазон произвольный ,кнопка test2,
для протягивания функция в столбце H,
приведите файл пример,можно видоизменить для любого варианта.

 Sub test2()
   Dim t$, z, i&, j&, i1&, t1$, m&
   z = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
 For j = 1 To UBound(z): m = 0
   t = z(j, 1)
   For i = 2 To Len(t)
     If Mid(t, i, 1) Like "[А-ЯЁ]" Then
       m = m + 1
       If m = 1 Then i1 = i: t1 = Left(t, i - 1)
       If m = 2 Then t = t1 & Chr(32) & Mid(t, i1, i - i1) & Chr(32) & Mid(t, i)
     End If
   Next i, j
  Range("C1").Resize(UBound(z), UBound(z, 2)).Value = z
End Sub

Function yyy$(t$)
   Dim i&, i1&, t1$, m&
   For i = 2 To Len(t)
     If Mid(t, i, 1) Like "[А-ЯЁ]" Then
       m = m + 1
       If m = 1 Then i1 = i: t1 = Left(t, i - 1)
       If m = 2 Then yyy = t1 & Chr(32) & Mid(t, i1, i - i1) & Chr(32) & Mid(t, i)
     End If
   Next
End Function

[svsh2016]

добрый вечер,протестируйте также универсальную функцию uuu
в столбце J,к примеру

Function uuu$(t$)
  With CreateObject("VBScript.RegExp"): .Pattern = "[А-ЯЁ]": .Global = True
    If .test(t) Then uuu = .Replace(t, " $&")
  End With
End Function