Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Переименование группы файлов с транслитерацией кириллицы - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Переименование группы файлов с транслитерацией кириллицы (Макросы/Sub)
Переименование группы файлов с транслитерацией кириллицы
rkhiller Дата: Среда, 04.10.2017, 20:07 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте!

Друзья, возникла проблема: другой макрос не видит файлы, в названии которых есть кириллица. При этом я нашел функцию, которая способна транслитерировать кириллицу в латиницу, но моих знаний не хватает на то, чтобы создать из этого полноценный макрос для повального переименования файлов в духе: есть определенная папка (скажем, C:\Users\User\Desktop, в ней файлы, например, 01_02_Иванов.xlxs, и надо её переименовать в 01_02_Ivanov.xlxs

Сама функция:

[vba]
Код
Function TranslitText(RusText As String) As String
    Dim RusAlphabet As Variant 'массив из букв русского алфавита
    RusAlphabet = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", "щ", "ъ", "ы", "ь", "э", "ю", "я")

    Dim EngAlphabet As Variant 'массив из букв английского алфавита
    EngAlphabet = Array("a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "tc", "ch", "sh", "shch", "", "y", "", "e", "iu", "ia")
    
    Dim EngText As String, Letter As String, Flag As Boolean
            
    For i = 1 To Len(RusText) 'цикл по всем символам русского текста
        Letter = Mid(RusText, i, 1)
        Flag = 0
        For j = 0 To 32 'цикл по всем буквам русского алфавита
            If RusAlphabet(j) = LCase(Letter) Then 'если символ из текста совпал с буквой из русского алфавита...
                Flag = 1
                If RusAlphabet(j) = Letter Then 'проверка на регистр (верхний или нижний)
                    EngText = EngText & EngAlphabet(j) '... то добавляем соответствующую букву из английского алфавита
                    Exit For
                Else
                    EngText = EngText & UCase(EngAlphabet(j))
                    Exit For
                End If
            End If
        Next j
        If Flag = 0 Then EngText = EngText & Letter 'если символа из текста в алфавите нет (например, знаки препинания и т.п.), то добавляем символ без изменения
    Next i
    TranslitText = EngText
End Function
[/vba]

Если кто поможет, буду сильно благодарен.
 
Ответить
СообщениеЗдравствуйте!

Друзья, возникла проблема: другой макрос не видит файлы, в названии которых есть кириллица. При этом я нашел функцию, которая способна транслитерировать кириллицу в латиницу, но моих знаний не хватает на то, чтобы создать из этого полноценный макрос для повального переименования файлов в духе: есть определенная папка (скажем, C:\Users\User\Desktop, в ней файлы, например, 01_02_Иванов.xlxs, и надо её переименовать в 01_02_Ivanov.xlxs

Сама функция:

[vba]
Код
Function TranslitText(RusText As String) As String
    Dim RusAlphabet As Variant 'массив из букв русского алфавита
    RusAlphabet = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", "щ", "ъ", "ы", "ь", "э", "ю", "я")

    Dim EngAlphabet As Variant 'массив из букв английского алфавита
    EngAlphabet = Array("a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "tc", "ch", "sh", "shch", "", "y", "", "e", "iu", "ia")
    
    Dim EngText As String, Letter As String, Flag As Boolean
            
    For i = 1 To Len(RusText) 'цикл по всем символам русского текста
        Letter = Mid(RusText, i, 1)
        Flag = 0
        For j = 0 To 32 'цикл по всем буквам русского алфавита
            If RusAlphabet(j) = LCase(Letter) Then 'если символ из текста совпал с буквой из русского алфавита...
                Flag = 1
                If RusAlphabet(j) = Letter Then 'проверка на регистр (верхний или нижний)
                    EngText = EngText & EngAlphabet(j) '... то добавляем соответствующую букву из английского алфавита
                    Exit For
                Else
                    EngText = EngText & UCase(EngAlphabet(j))
                    Exit For
                End If
            End If
        Next j
        If Flag = 0 Then EngText = EngText & Letter 'если символа из текста в алфавите нет (например, знаки препинания и т.п.), то добавляем символ без изменения
    Next i
    TranslitText = EngText
End Function
[/vba]

Если кто поможет, буду сильно благодарен.

Автор - rkhiller
Дата добавления - 04.10.2017 в 20:07
_Boroda_ Дата: Среда, 04.10.2017, 20:30 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
На самом деле я бы занялся как раз тем макросом, который
не видит файлы, в названии которых есть кириллица
. Апартеид какой-то, честное слово! Что-то там не то.
А переименование - не думаю, что это хорошее решение
Но если очень хочется - в этой теме http://www.programmersforum.ru/showthread.php?t=60191 пост №6, макрос №2
Строку
[vba]
Код
NewFilename = НовоеИмяФайла(sh.Cells(2, 1), sh.Cells(8, 1))
[/vba]
переписываете примерно так
[vba]
Код
NewFilename = TranslitText(file)
[/vba]
Ну и конечно ниже (или выше) того макроса должен лежать и приведенный Вами латинизатор


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеНа самом деле я бы занялся как раз тем макросом, который
не видит файлы, в названии которых есть кириллица
. Апартеид какой-то, честное слово! Что-то там не то.
А переименование - не думаю, что это хорошее решение
Но если очень хочется - в этой теме http://www.programmersforum.ru/showthread.php?t=60191 пост №6, макрос №2
Строку
[vba]
Код
NewFilename = НовоеИмяФайла(sh.Cells(2, 1), sh.Cells(8, 1))
[/vba]
переписываете примерно так
[vba]
Код
NewFilename = TranslitText(file)
[/vba]
Ну и конечно ниже (или выше) того макроса должен лежать и приведенный Вами латинизатор

Автор - _Boroda_
Дата добавления - 04.10.2017 в 20:30
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Переименование группы файлов с транслитерацией кириллицы (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!