Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1 2 След.
RSS
Транслитерация текста в ячейке
 
#1
25.06.2012 14:31:08
Существует задача транслитерировать ФИО с сокращением ИО    
Работа происходит с многолистовым документом в котором хранятся пароли, лист - отдел.  
Структура такая столбец А - ФИО в виде Иванов Иван Иванович, столбец В - login в виде ivanovii, С - пароль.  
 
Находил на форуме разные варианты, но к сожалению у меня не получилось их прикрутить(  
 
 
В идеале надо что бы на заданных листах(потому что не на всех такая структура) что то анализировало столбец А и при появлении там ФИО транслитерировало его по вышеописанному принципу в В, при этом понимание того что это новый юзер, а не изменение старого осуществлялось по заполненности ячейки в столбце С...ну во всяком случае я как то так себе это представляю...  
Если анализ в реальном времени затруднителен или не возможен, то хотя бы что бы это действие выполнялось по горячей кнопке.    
 
 
Заранее спасибо!
 
 
 
#2
25.06.2012 14:43:48
Без Вашего файла-примера (что есть - что и где хочу) мало кто будет Вам помогать.
 
 
 
#3
25.06.2012 15:07:34
По соображениям безопасности чуть измененный, но не потерявший смысла структуры документ в аттаче.  
 
<EM><STRONG>Файл удален</STRONG> - велик размер - [<STRONG>МОДЕРАТОРЫ</STRONG>]</EM>
 
 
 
#4
25.06.2012 15:13:08
Попробуйте еще раз и в формате 2003. Ваш файл не открывается. И следите за размером (не более 100 кБ)
 
 
 
#5
25.06.2012 15:16:52
Миш, привет. И я загрузить не смог.  
 
75070
Я сам - дурнее всякого примера! ...
 
 
 
#6
25.06.2012 15:22:37
Привет!  
Игорь, файл то открывается, но без данных,только макросы.
 
 
 
#7
25.06.2012 15:27:13
Мои извинения!Дубль 2.  
 
Сохранено в формате xls, удалена картинка с фона, но вес 132 кб...как меньше сделать не знаю.  
 
<EM><STRONG>Файл удален</STRONG> - велик размер - [<STRONG>МОДЕРАТОРЫ</STRONG>]</EM>
 
 
 
#8
25.06.2012 15:29:37
{quote}{login=SIMRus}{date=25.06.2012 03:27}{thema=}{post}  
как меньше сделать не знаю.{/post}{/quote}В архив, предпочтительно .rar
 
 
 
#9
25.06.2012 15:33:18
ЗЫ и этот файл не открывается. :(  
 
зы.зы Создайте пример в новой книге, и в примере оставьте только то, что касается вопроса.
 
 
 
#10
25.06.2012 15:34:09
А у меня вообще не загрузился.  
PS Сергей. Игорь у нас Hugo:-)
Я сам - дурнее всякого примера! ...
 
 
 
#11
25.06.2012 15:43:26
{quote}{login=KukLP}{date=25.06.2012 03:34}{thema=}{post}  
PS Сергей. Игорь у нас Hugo:-){/post}{/quote}Сереж, прошу прощения; у нас жара - 32 в тени.
 
 
 
#12
25.06.2012 15:44:06
Дубль 3
 
 
 
#13
25.06.2012 15:48:51
Миш, у меня уже нет времени, вот функция транслит, а ты уж дальше давай:  
Function Translit(txt As String) As String  
   Dim i%, c$, flag As Boolean, j%, outchr$, outstr$  
   Dim RUS As Variant  
   RUS = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", _  
               "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _  
               "щ", "ъ", "ы", "ь", "э", "ю", "я", "А", "Б", "В", "Г", "Д", "Е", _  
               "Ё", "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", _  
               "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я")  
   Dim Eng As Variant  
   Eng = Array("a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "j", _  
               "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _  
               "sh", "sch", "''", "y", "'", "e", "yu", "ya", "A", "B", "V", "G", "D", _  
               "E", "JO", "ZH", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", _  
               "S", "T", "U", "F", "KH", "TS", "CH", "SH", "SCH", "''", "Y", "'", "E", "YU", "YA")  
 
   For i = 1 To Len(txt)  
       c = Mid(txt, i, 1)  
       flag = 0  
       For j = 0 To 65  
           If RUS(j) = c Then  
               outchr = Eng(j)  
               flag = 1  
               Exit For  
           End If  
       Next j  
       If flag Then outstr = outstr & outchr Else outstr = outstr & c  
   Next i  
   Translit = outstr  
End Function
Я сам - дурнее всякого примера! ...
 
 
 
#14
25.06.2012 16:17:09
Дописал оболочку  
 
Function FamIO(s As String) As String  
Dim x, p2  
For Each x In Split(s)  
   If p2 Then  
       FamIO = FamIO & LCase(Left(Translit((x)), 1))  
   Else  
       FamIO = LCase(Translit((x)))  
       p2 = True  
   End If  
Next  
End Function  
 
Применять на листе так: =famio(A2)
 
 
 
#15
25.06.2012 16:48:46
ну и мой вариант
 
 
 
#16
25.06.2012 20:22:30
Протестил Ваш вариант, он подходит полностью!Спасибо!  
Жаль уже 300 юзерам пароли раздали, а то бы вообще отлично было)  
 
Единственная просьба внести маленькую корректировку в код:  
логин формируется из ФИО, где фамилия пишется полностью(как есть), а имя и отчество сокращается до одной буквы.  
В Вашем же варианте если имя или отчество начинается с букв которые в транслитерации дают две(ж, ш, ч итд) то выглядит примерно так:  
Кещян Жанна Васильевна keschyanzhv,    
а должно так:  
Кещян Жанна Васильевна keschyanzv
 
 
 
#17
25.06.2012 21:01:26
А у меня это учтено :)
 
 
 
#18
25.06.2012 22:07:26
Маленькая "полировка" функции Сергея: массив удобнее и КОРОЧЕ задавать не через Array а через Split:  
Function Translit$(txt$)  
   Dim i%, c$, j%, outChr$, outStr$, flag As Boolean  
   Dim RUS: RUS = Split("а б в г д е ё ж з и й к л м н о п р с т у ф х ц ч ш щ ъ ы ь э ю я А Б В Г Д Е Ё Ж З И Й К Л М Н О П Р С Т У Ф Х Ц Ч Ш Щ Ъ Ы Ь Э Ю Я")  
   Dim Eng: Eng = Split("a b v g d e jo zh z i j k l m n o p r s t u f kh ts ch sh sch '' y ' e yu ya A B V G D E JO ZH Z I J K L M N O P R S T U F KH TS CH SH SCH '' Y ' E YU YA")  
   For i = 1 To Len(txt)  
       c = Mid(txt, i, 1)  
       flag = False  
       For j = 0 To 65  
           If RUS(j) = c Then  
               outChr = Eng(j)  
               flag = True  
               Exit For  
           End If  
       Next j  
       outStr = outStr & IIf(flag, outChr, c)  
   Next i  
   Translit = outStr  
End Function
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
 
 
#19
25.06.2012 22:43:50
Внес поправку
 
 
 
#20
25.06.2012 23:06:17
Леш,дружище, это не моя функция. Просто валяется в общей свалке. Даже не помню, где взял. Поэтому без ссылки на автора. Я бы переписал ее совсем иначе, но лень:-) Но все равно, спасибо.  
И второй Леша(Казанский) - спасибо, радует, что мы друг друга поддерживаем. А ты у нас так вообще, умничка!
Я сам - дурнее всякого примера! ...
 
 
 
#21
25.06.2012 23:12:19
{quote}{login=KukLP}{date=25.06.2012 11:06}{thema=Re: Alex_ST}{post}это не моя функция. Просто валяется в общей свалке. Даже не помню, где взял.{/post}{/quote} <BR> http://www.planetaexcel.ru/tip.php?aid=110
 
 
 
#22
25.06.2012 23:29:30
Спасибо Миш. Только помню, что точно брал ее не оттуда. Я туда не заглядываю:-) Мне не нужно... А, кстати и автора там не нашел. Так и мои(и не только) наработки гуляют по инету без авторства. Это ИМХО нормально. Задевает только немного, когда кто-то приписывает себе авторство. Но Бог с ним, несущественно. Я открещиваюсь от авторства, когда мне его приписывают(абсолютно без умысла, мои друзья по форумам) - а кто-то промолчит, не открестится:-) Не суть важно. Главное, чтоб на пользу людям:-)
Я сам - дурнее всякого примера! ...
 
 
 
#23
25.06.2012 23:42:28
\и еще небольшой плевок  
 
   Static RUS As Variant  
   If IsEmpty(RUS) Then  
       RUS = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", _  
               "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _  
               "щ", "ъ", "ы", "ь", "э", "ю", "я")  
   End If
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук

https://github.com/nervgh
 
 
 
#24
26.06.2012 01:01:03
Если задуматься об оптимизации, то поиск русской буквы в массиве не нужен - достаточно расположить английские строки в порядке возрастания кодов русских букв (только буквы ё, Ё выбиваются из общего ряда). И еще кое-что. В результате на строке длиной 820 при многократном вызове работает в 20 раз быстрее, чем функция Translit с предыдущей страницы.  
Можно оптимизировать еще, но существенное ускорение вряд ли будет.  
 
Function TranslitFast(txt$) As String  
Static Eng$()  
Dim out$, i&, j&, k&  
k = 1  
On Error Resume Next  
If UBound(Eng) < 5 Then Eng = Split("A B V G D E ZH Z I J K L M N O P R S T U F KH TS CH SH SCH '' Y ' E YU YA a b v g d e zh z i j k l m n o p r s t u f kh ts ch sh sch '' y ' e yu ya JO jo")  
out = Space(Len(txt) * 3)  
For i = 1 To Len(txt)  
   j = AscW(Mid$(txt, i, 1)) - 1040  
   Select Case j  
   Case 0 To 63, 65            'А-Я,а-я,ё  
       Mid(out, k) = Eng(j)  
       k = k + Len(Eng(j))  
   Case -15                    'Ё  
       Mid(out, k) = Eng(64)  
       k = k + 2  
   Case Else                   'символы, не явл. русскими буквами  
       Mid(out, k) = Mid$(txt, i, 1)  
       k = k + 1  
   End Select  
Next  
TranslitFast = Left$(out, k - 1)  
End Function
 
 
 
#25
26.06.2012 08:41:20
re: MCH  
Ваш вариант самый подходящий!  
 
 
Спасибо за участие!  
Спасибо за результат!  
Всем спасибо!!!!
 
 
 
#26
26.06.2012 09:02:01
Поспешил(  
Пример работает отлично, а вот в свой документ к сожалению прикрутить не могу...  
формат xlsm, Excel 2010.  
Пересохранял в xls, 2003 результат тот же...    
 
Вставил код, в ячейке пишу функцию, все как в примере, но результата нет(  
Единственно не знаю куда поставить Option Explicit, добавляется к вышестоящему блоку и при его выполнении выдает ошибку..
 
 
 
#27
26.06.2012 09:27:25
Да что там крутить...  
Открываете оба документа, Alt+F11, в редакторе тянетен мышью модуль целиком из одного документа в другой.  
Всё, можно пользоваться.  
 
И Option Explicit будет на месте.
 
 
 
#28
26.06.2012 09:55:40
Не поверите, все так и делаю)  
Что касается Option Explicit, если добавлять после моих модулей, то он клеется к последнему, а не существует сам по себе. Но я просто все это вставил в самое начало, но результата опять же не дало(
 
 
 
#29
26.06.2012 10:00:16
Пробовал разные варианты. Возможно я чего то не понимаю, но на листе 2 в примере тоже не работает(
 
 
 
#30
26.06.2012 10:05:38
Значит что-то не так делаете (хотя где тут можно не так, не знаю...)  
Ну а Option Explicit всего лишь заставляет объявлять все переменные модуля.  
Эта строка должна быть одна на модуль, в самом начале.  
Если мешает и не понятно - удалите её, хуже не станет :)
 
 
 
Страницы: 1 2 След.
Читают тему
Наверх