Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Сократить имя, отчество
 
#1
26.08.2010 12:07:03
Всем привет, подскажите пожалуйста макрос для сокращения имени и отчества до инициалов, т.е из "Иванов Иван Иванович" сделать "Иванов И.И."
 
 
 
#2
26.08.2010 12:09:49
а фамилия всегда первая?
 
 
 
#3
26.08.2010 12:11:31
Формулами точно не надо?
 
 
 
#4
26.08.2010 12:26:56
Да фамилия всегда первая.  
Макрос предпочтительнее)
 
 
 
#5
26.08.2010 12:30:26
{quote}{login=Serge 007}{date=26.08.2010 12:11}{thema=}{post}Формулами точно не надо?{/post}{/quote}  
 
Не любят формулы они, Сергей.
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
 
 
 
#6
26.08.2010 12:34:01
Владимир, если нужно это выполнить "на месте", то с формулами возникнут сложности :-) Поэтому, наверное, и спрашивает про макрос.
 
 
 
#7
26.08.2010 12:37:58
сначала загна не в ту тему  
Sub fio()  
Dim rr As Range  
Dim i  
 
Dim rra(), rrr()  
Set rr = Selection  
rra = rr  
For i = LBound(rra) To UBound(rra)  
rrr() = Split(rra(i, 1))'отладчику не нравится эта строка, type mismatch  
rrr(0) = Trim(rrr(0)) & " "  
rrr(1) = Left(rrr(1), 1) & "."  
rrr(2) = Left(rrr(2), 1) & "."  
rra(i, 1) = Join(rrr, "")  
Next  
rr = rra  
End Sub
 
 
 
#8
26.08.2010 12:40:02
Вставить в нужное место:  
 
       FullFIO = "Иванов Иван Иванович"  
       FIO = Split(FullFIO, " ")  
       If UBound(FIO) >= 3 Then MsgBox "Что-то не так..." Else ShortFIO = FIO(0) & " " & Left(FIO(1), 1) & "." & Left(FIO(2), 1) & "."  
 
На выходе: Иванов И.И.  
Проверка на всякий случай, чтобы в исходной строке не было больше трёх слов (а точнее - больше двух пробелов)
 
 
 
#9
26.08.2010 12:50:24
Sub fio()  
Dim rr As Range  
Dim i  
Dim ddd  
Dim rra(), rrr()  
Set rr = Selection  
rra = rr  
For i = LBound(rra) To UBound(rra)  
ddd = Application.WorksheetFunction.Trim(rra(i, 1))  
rrr() = Split(ddd, " ") 'все равно выбрасывает  
If UBound(rrr) >= 3 Then  
MsgBox "что-то не так..."  
Else  
rrr(0) = rrr(0) & " "  
rrr(1) = Left(rrr(1), 1) & "."  
rrr(2) = Left(rrr(2), 1) & "."  
rra(i, 1) = Join(rrr, "")  
End If  
Next  
rr = rra  
End Sub
 
 
 
#10
26.08.2010 13:09:19
Я, если честно, не пытался поправить макрос Тухачевского, а предложил свой с расчетом на то, что эти строки вставить в нужное место уже существующего какого-то макроса. А если отдельно его сделать, то можно так:  
 
Sub sFIO()  
   For Each rcell In Selection.Cells  
       FullFIO = rcell.Value  
       fio = Split(Application.WorksheetFunction.Trim(FullFIO), " ")  
       If UBound(fio) <= 3 Then  
           ShortFIO = fio(0) & " " & Left(fio(1), 1) & "." & Left(fio(2), 1) & "."  
           rcell.Value = ShortFIO  
       End If  
   Next  
End Sub  
 
(спасибо за идею с Application.WorksheetFunction.Trim :))
 
 
 
#11
26.08.2010 13:22:18
Sub FIO()  
Dim strF As String  
Dim arrStr() As String  
   strF = Trim(CStr(ActiveCell.Value))  
   arrStr = Split(strF, " ", -1, vbTextCompare)  
   ActiveCell.Offset(0, 1).Value = arrStr(0) & " " & Left(arrStr(1), 1) & "." & Left(arrStr(2), 1) & "."  
End Sub  
 
Вопрос только возникает, как быть, если фамилия содержит пробел, или отчества нет вообще.
Кому решение нужно - тот пример и рисует.
 
 
 
#12
26.08.2010 13:33:43
Спасибо за "Split"! ;)  
 
Чуть не изобрел велосипед :)  
 
Возможно такой вариант подойдет.
<FONT COLOR="CadetBlue">
 
 
 
#13
26.08.2010 13:57:00
Всем большое спасибо за помощь!
 
 
 
#14
26.08.2010 15:40:10
А как сделать при помощи макроса:  
"Иванов Иван Иванович" сделать "И.И. Иванов"
 
 
 
#15
26.08.2010 15:45:02
Sub FIO()  
Dim strF As String  
Dim arrStr() As String  
strF = Trim(CStr(ActiveCell.Value))  
arrStr = Split(strF, " ", -1, vbTextCompare)  
ActiveCell.Offset(0, 1).Value = Left(arrStr(2), 1) & "." &  Left(arrStr(1), 1) & ". " & arrStr(0)  
End Sub
Кому решение нужно - тот пример и рисует.
 
 
 
#16
26.08.2010 15:48:50
Попробуйте так:  
Sub qqq()  
x = Split(Cells(1, 1))  
Cells(1, 1) = Left(x(1), 1) & ". " & Left(x(2), 1) & ". " & x(0)  
End Sub
 
 
 
#17
26.08.2010 16:07:26
Всем СПАСИБО!  
Вопрос снят.
 
 
 
#18
22.11.2011 16:30:57
{quote}{login=Serge 007}{date=26.08.2010 12:11}{thema=}{post}Формулами точно не надо?{/post}{/quote}  
А как это можно сделать формулами?
 
 
 
#19
22.11.2011 16:36:13
Можно. Было не раз. Вы не ту тему нашли :)
 
 
 
#20
22.11.2011 16:37:00
=ЛЕВСИМВ(A1;НАЙТИ(" ";A1;1)+1)&". "&ПСТР(A1;НАЙТИ(" ";A1;НАЙТИ(" ";A1;1)+1)+1;1)&"."  
 
 
-----  
26669
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
 
 
 
#21
22.11.2011 17:04:40
{quote}{login=vikttur}{date=22.11.2011 04:36}{thema=}{post}Можно. Было не раз. Вы не ту тему нашли :){/post}{/quote}  
В поиске попалась только эта тема.  
 
Владимир, большое спасибо!
 
 
 
#22
25.11.2011 12:12:21
Всем огромное СПАСИБО! Спасли время и нервы:)
 
 
 
#23
25.11.2011 12:42:43
{quote}{login=Пытливый}{date=26.08.2010 03:45}{thema=}{post}Sub FIO()  
Dim strF As String  
Dim arrStr() As String  
strF = Trim(CStr(ActiveCell.Value))  
arrStr = Split(strF, " ", -1, vbTextCompare)  
ActiveCell.Offset(0, 1).Value = Left(arrStr(2), 1) & "." &  Left(arrStr(1), 1) & ". " & arrStr(0)  
End Sub{/post}{/quote}  
 
можно так  
добавил  
Sub FIO()  
Dim strF As String  
Dim arrStr() As String  
Dim i, x As Integer  
x = Cells(Rows.Count, 1).End(xlUp).Row  
For i = 1 To x  
strF = Trim(CStr(Cells(i, 1).Value))  
arrStr = Split(strF, " ", -1, vbTextCompare)  
Cells(i, 2).Value = arrStr(0) & " " & Left(arrStr(1), 1) & "." & Left(arrStr(2), 1) & "."  
Next  
End Sub
 
 
 
Страницы: 1
Читают тему
Наверх