Заменить Function на Sub
baaur
Дата: Вторник, 20.10.2015, 09:30 |
Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 70
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
Добрый день, всем Уважаемые знатоки, не могли бы вы подсказать как можно переделать или заменить в Function что бы работала только на определенную ячейку как Sub. То есть файлы и нужно что бы макрос после нажатия кнопки срабатывал только на одну ячейку. D7 например.
Добрый день, всем Уважаемые знатоки, не могли бы вы подсказать как можно переделать или заменить в Function что бы работала только на определенную ячейку как Sub. То есть файлы и нужно что бы макрос после нажатия кнопки срабатывал только на одну ячейку. D7 например. baaur
Ответить
Сообщение Добрый день, всем Уважаемые знатоки, не могли бы вы подсказать как можно переделать или заменить в Function что бы работала только на определенную ячейку как Sub. То есть файлы и нужно что бы макрос после нажатия кнопки срабатывал только на одну ячейку. D7 например. Автор - baaur Дата добавления - 20.10.2015 в 09:30
SLAVICK
Дата: Вторник, 20.10.2015, 09:39 |
Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация:
766
±
Замечаний:
0% ±
2019
Не понимаю зачем такое нужно, но вот например так:
[vba]
Код
Function Translit() As String ' с учётом регистра символов Dim txt$ Application.Volatile txt = ActiveSheet.[d9]'ThisWorkbook.Sheets("Лист1").[d9] txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba]
В какую бы Вы ячейку не прописали эту функцию - она будет возвращать транслит только для активного листа - ячейки [d9]. Можно прописать вообще жесткую привязку к листу и ячейке, тогда так: [vba]Код
txt = ThisWorkbook.Sheets("Лист1").[d9]
[/vba]
Не понимаю зачем такое нужно, но вот например так:
[vba]
Код
Function Translit() As String ' с учётом регистра символов Dim txt$ Application.Volatile txt = ActiveSheet.[d9]'ThisWorkbook.Sheets("Лист1").[d9] txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba]
В какую бы Вы ячейку не прописали эту функцию - она будет возвращать транслит только для активного листа - ячейки [d9]. Можно прописать вообще жесткую привязку к листу и ячейке, тогда так: [vba]Код
txt = ThisWorkbook.Sheets("Лист1").[d9]
[/vba] SLAVICK
Иногда все проще чем кажется с первого взгляда.
Сообщение отредактировал SLAVICK - Вторник, 20.10.2015, 09:45
Ответить
Сообщение Не понимаю зачем такое нужно, но вот например так:
[vba]
Код
Function Translit() As String ' с учётом регистра символов Dim txt$ Application.Volatile txt = ActiveSheet.[d9]'ThisWorkbook.Sheets("Лист1").[d9] txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba]
В какую бы Вы ячейку не прописали эту функцию - она будет возвращать транслит только для активного листа - ячейки [d9]. Можно прописать вообще жесткую привязку к листу и ячейке, тогда так: [vba]Код
txt = ThisWorkbook.Sheets("Лист1").[d9]
[/vba] Автор - SLAVICK Дата добавления - 20.10.2015 в 09:39
Roman777
Дата: Вторник, 20.10.2015, 09:47 |
Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация:
127
±
Замечаний:
0% ±
Excel 2007, Excel 2013
Можно просто в отдельной процедуре Sub использовать данную функцию для определённой ячейки. [vba]Код
Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function Sub Transclited() Cells(1, 1) = Translit(Cells(1, 1)) End Sub
[/vba]
Можно просто в отдельной процедуре Sub использовать данную функцию для определённой ячейки. [vba]Код
Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function Sub Transclited() Cells(1, 1) = Translit(Cells(1, 1)) End Sub
[/vba] Roman777
Много чего не знаю!!!!
Сообщение отредактировал Roman777 - Вторник, 20.10.2015, 09:51
Ответить
Сообщение Можно просто в отдельной процедуре Sub использовать данную функцию для определённой ячейки. [vba]Код
Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function Sub Transclited() Cells(1, 1) = Translit(Cells(1, 1)) End Sub
[/vba] Автор - Roman777 Дата добавления - 20.10.2015 в 09:47
baaur
Дата: Вторник, 20.10.2015, 09:48 |
Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 70
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
Добрый день, SLAVICK , спасибо за ответ, только почему то не работает я имел ввиду что будет Sub, и вывести кнопку что бы макрос менял автоматом только данные в одной ячейке.
Добрый день, SLAVICK , спасибо за ответ, только почему то не работает я имел ввиду что будет Sub, и вывести кнопку что бы макрос менял автоматом только данные в одной ячейке. baaur
Ответить
Сообщение Добрый день, SLAVICK , спасибо за ответ, только почему то не работает я имел ввиду что будет Sub, и вывести кнопку что бы макрос менял автоматом только данные в одной ячейке. Автор - baaur Дата добавления - 20.10.2015 в 09:48
baaur
Дата: Вторник, 20.10.2015, 09:49 |
Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 70
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
Roman777 , то есть как? простите я не знаю.
Roman777 , то есть как? простите я не знаю.baaur
Ответить
Сообщение Roman777 , то есть как? простите я не знаю.Автор - baaur Дата добавления - 20.10.2015 в 09:49
Roman777
Дата: Вторник, 20.10.2015, 09:52 |
Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация:
127
±
Замечаний:
0% ±
Excel 2007, Excel 2013
baaur , добавил в тот же модуль ниже процедуру в сообщении №3 видно: [vba]Код
Sub Transclited() Cells(1, 1) = Translit(Cells(1, 1)) End Sub
[/vba]
baaur , добавил в тот же модуль ниже процедуру в сообщении №3 видно: [vba]Код
Sub Transclited() Cells(1, 1) = Translit(Cells(1, 1)) End Sub
[/vba]Roman777
Много чего не знаю!!!!
Ответить
Сообщение baaur , добавил в тот же модуль ниже процедуру в сообщении №3 видно: [vba]Код
Sub Transclited() Cells(1, 1) = Translit(Cells(1, 1)) End Sub
[/vba]Автор - Roman777 Дата добавления - 20.10.2015 в 09:52
baaur
Дата: Вторник, 20.10.2015, 09:52 |
Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 70
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
Roman777 , Спасибо большое!!! получилось
Roman777 , Спасибо большое!!! получилосьbaaur
Ответить
Сообщение Roman777 , Спасибо большое!!! получилосьАвтор - baaur Дата добавления - 20.10.2015 в 09:52
SLAVICK
Дата: Вторник, 20.10.2015, 09:54 |
Сообщение № 8
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация:
766
±
Замечаний:
0% ±
2019
Ну тогда просто добавить простенький макрос:
[vba]
Код
Sub testMe() Dim txt$ txt = Translit(CStr([d7])) [d7] = txt End Sub Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba]
ОЙ - меня опередили
Ну тогда просто добавить простенький макрос:
[vba]
Код
Sub testMe() Dim txt$ txt = Translit(CStr([d7])) [d7] = txt End Sub Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba]
ОЙ - меня опередили SLAVICK
Иногда все проще чем кажется с первого взгляда.
Сообщение отредактировал SLAVICK - Вторник, 20.10.2015, 09:56
Ответить
Сообщение Ну тогда просто добавить простенький макрос:
[vba]
Код
Sub testMe() Dim txt$ txt = Translit(CStr([d7])) [d7] = txt End Sub Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba]
ОЙ - меня опередили Автор - SLAVICK Дата добавления - 20.10.2015 в 09:54
baaur
Дата: Вторник, 20.10.2015, 09:57 |
Сообщение № 9
Группа: Пользователи
Ранг: Участник
Сообщений: 70
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
SLAVICK , спасбо большое!!! Так же работает.
SLAVICK , спасбо большое!!! Так же работает.baaur
Ответить
Сообщение SLAVICK , спасбо большое!!! Так же работает.Автор - baaur Дата добавления - 20.10.2015 в 09:57
baaur
Дата: Вторник, 20.10.2015, 09:59 |
Сообщение № 10
Группа: Пользователи
Ранг: Участник
Сообщений: 70
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
Уважаемые, а можно вопрос, в этом макросе он не совсем корректно переделывает некоторые имена/фамилии Например Юлия он прописывает как YUliya можно ли как нибудь это исправить?
Уважаемые, а можно вопрос, в этом макросе он не совсем корректно переделывает некоторые имена/фамилии Например Юлия он прописывает как YUliya можно ли как нибудь это исправить? baaur
Ответить
Сообщение Уважаемые, а можно вопрос, в этом макросе он не совсем корректно переделывает некоторые имена/фамилии Например Юлия он прописывает как YUliya можно ли как нибудь это исправить? Автор - baaur Дата добавления - 20.10.2015 в 09:59
baaur
Дата: Вторник, 20.10.2015, 10:01 |
Сообщение № 11
Группа: Пользователи
Ранг: Участник
Сообщений: 70
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
Или просто макрос не может это корректно прописывать?
Или просто макрос не может это корректно прописывать? baaur
Ответить
Сообщение Или просто макрос не может это корректно прописывать? Автор - baaur Дата добавления - 20.10.2015 в 10:01
SLAVICK
Дата: Вторник, 20.10.2015, 10:03 |
Сообщение № 12
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация:
766
±
Замечаний:
0% ±
2019
Макрос здесь ни при чем - это баг функции - нужно ее подкорректировать. Сейчас посмотрю
Макрос здесь ни при чем - это баг функции - нужно ее подкорректировать. Сейчас посмотрю SLAVICK
Иногда все проще чем кажется с первого взгляда.
Ответить
Сообщение Макрос здесь ни при чем - это баг функции - нужно ее подкорректировать. Сейчас посмотрю Автор - SLAVICK Дата добавления - 20.10.2015 в 10:03
SLAVICK
Дата: Вторник, 20.10.2015, 10:15 |
Сообщение № 13
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация:
766
±
Замечаний:
0% ±
2019
Ну вот: [vba]Код
Sub testMe() Dim txt$ txt = Translit(CStr([d7])): [d7] = txt End Sub Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), StrConv(arrTranslit(iCount%), 3), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba]
Ну вот: [vba]Код
Sub testMe() Dim txt$ txt = Translit(CStr([d7])): [d7] = txt End Sub Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), StrConv(arrTranslit(iCount%), 3), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba] SLAVICK
Иногда все проще чем кажется с первого взгляда.
Сообщение отредактировал SLAVICK - Вторник, 20.10.2015, 10:16
Ответить
Сообщение Ну вот: [vba]Код
Sub testMe() Dim txt$ txt = Translit(CStr([d7])): [d7] = txt End Sub Function Translit(txt As String) As String ' с учётом регистра символов txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _ "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _ "sh", "sch", "", "y", "", "e", "yu", "ya") For iCount% = 1 To 33 txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), StrConv(arrTranslit(iCount%), 3), , , vbBinaryCompare) ' прописные Next Translit$ = txt$ End Function
[/vba] Автор - SLAVICK Дата добавления - 20.10.2015 в 10:15
baaur
Дата: Вторник, 20.10.2015, 10:29 |
Сообщение № 14
Группа: Пользователи
Ранг: Участник
Сообщений: 70
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
SLAVICK , Превосходно, Благодарю!!!
SLAVICK , Превосходно, Благодарю!!!baaur
Ответить
Сообщение SLAVICK , Превосходно, Благодарю!!!Автор - baaur Дата добавления - 20.10.2015 в 10:29