Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Точки в ФИО
 
#1
20.04.2011 16:00:06
Доброго времени суток, ув. форумчане! Я обычный пользователь в работе с Excel, потому возникла такая проблема. Есть бесконечный список клиентов и условия их внесения в базу. Но проблема в том, что до меня эти условия не соблюдались, а именно не везде ставили точки после инициалов или вставляли пробелы. Теперь эту ситуацию необходимо исправить, но вручную это делать довольно накладно. Усложняется все тем, что клиенты могут быть необязательно с ИО, если это не ЧП. Для наглядности прилагаю файл. Можно как-то решить эту задачу? Заранее благодарна.
 
 
 
#2
20.04.2011 17:06:59
Мы занимались этим вопросом на форуме  
http://excel-vba.ru/file/excel-vba_ru/FunctionsMoveAndReplace_v2.rar целая тема была наберите в поиске расческа.
 
 
 
#3
20.04.2011 17:42:40
К сожалению, запрашиваемая тема не существует (выпадает ошибка). И в поисковике ничего не находит :( Но все равно спасибо, попробую так поискать.
 
 
 
#4
20.04.2011 18:29:28
Не выдумывайте сам набрал в поиске расческа и нашел ..был ее активным участником.
 
 
 
#5
20.04.2011 18:39:44
Function A_Ф(Фам_Имя_Отч) As String  
   Dim strText, le&, lle&  
   Фам_Имя_Отч = Replace(Фам_Имя_Отч, ".", " ")  
   Фам_Имя_Отч = Application.Trim(Фам_Имя_Отч)  
   strText = Split(Фам_Имя_Отч, " ")  
   lle = UBound(strText)  
Select Case strText(UBound(strText))  
Case "ЧП", "ООО"  
If UBound(strText) <= 1 Then A_Ф = Фам_Имя_Отч: Exit Function  
   lle = lle - 1  
   End Select  
   For le = LBound(strText) To lle  
       If le = 0 Then  
           A_Ф = strText(le) & " "  
       ElseIf le > 2 Then  
           Exit For  
       Else  
           A_Ф = A_Ф & Left(strText(le), 1) & "."  
       End If  
   Next le  
   If lle <> UBound(strText) Then A_Ф = A_Ф & " " & strText(UBound(strText))  
End Function
 
 
 
#6
20.04.2011 18:50:11
Такой вариант:  
 
Sub rtyrty()  
Dim rng As Range, r As Range  
Dim x As String, i As Long, str As String * 5  
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)  
With CreateObject("VBScript.RegExp")  
   .Pattern = "[А-Я]\.?\s?[А-Я]\.?\s"
   For Each r In rng  
       If .Test® Then  
           x = .Execute(r.Value)(0)  
           Mid(str, 1, 2) = Mid(x, 1, 1) & "."  
           For i = 2 To Len(x) - 1  
               If Mid(x, i, 1) Like "[А-Я]" Then
                   Mid(str, 3, 3) = Mid(x, i, 1) & ". "  
               End If  
           Next  
        r = .Replace(r, str)  
       End If  
   Next r  
End With  
End Sub  
 
В файле - зеленая стрелка.
 
 
 
#7
20.04.2011 21:37:26
Сложил всё в кучку, добавил свою UDF.  
Лучшие результаты у макроса.
 
 
 
#8
20.04.2011 23:48:59
Спасибо всем огромное за помощь! Буду пробовать :)
 
 
 
Страницы: 1
Читают тему
Наверх