mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

ВНИМАНИЕ: Данная программа использует вызов системных функций - WinAPI
Поскольку синтаксис вызова этих функций в различных версиях Windows и Office может отличаться, работа программы на всех компьютерах не гарантируется!
Все размещённые на сайте макросы тестировались в Excel 2003 - 2010 под управлением 32-битной версии Windows XP

Если вы работаете в 64-битной версии Windows, или используете Office 2010 или 2013 (в котором встроена 7-я версия VBA),
то есть вероятность, что макрос работать не будет (потребуется доработка вызова функций WinAPI)
По указанным причинам, макрос не будет работать под управлением MacOS Excel 2004, 2008, 2011 и т.п.)

Автоматическое переключение раскладки клавиатуры для разных диапазонов ячеек

Данный макрос автоматизирует процесс переключения раскладки клавиатуры (смену языков ввода) при работе с таблицами в Excel.

К примеру, вы заносите данные в таблицу, где в некоторые столбцы требуется вводить русские слова (фамилия, имя, и т.п.), а в другие столбцы - английские (марка и модель авто, и т.д.)

Чтобы каждый раз не переключать раскладку вручную - можно воспользоваться WinAPI функцией ActivateKeyboardLayout

Вставьте этот код в модуль листа:

Private Declare Function ActivateKeyboardLayout _
                          Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Select Case Target.Column    ' в зависимости от номера столбца активной ячеки
        Case 1 To 3, 6    ' для столбцов Имя, Фамилия, Номер машины, Цвет
            ВключитьРусскуюРаскладку
        Case 4, 5:    ' для столбцов Марка авто, Модель
            ВключитьАнглийскуюРаскладку
        Case Else:    ' ничего не делаем (оставляем текущую раскладку)
    End Select
End Sub
 
Sub ВключитьРусскуюРаскладку()
    ' Переключить на русский язык
    x = ActivateKeyboardLayout&(kb_lay_ru, 0)
End Sub
 
Sub ВключитьАнглийскуюРаскладку()
    ' Переключить на английский язык
    x = ActivateKeyboardLayout&(kb_lay_en, 0)
End Sub

ВложениеРазмерЗагрузкиПоследняя загрузка
KeyboardLayout.xls23.5 КБ586 недель 2 дня назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Доброе время.Как организовать это в word2007? Есть таблица на два столбца, в один ввод (не копирование откуда-нибудь) русский, в другой - чел. делает ввод по-английски. Никакие предварительные установки не держатся, selection тоже не помогает. Спасибо.

Спасибо. Заработало сразу.

Не подскажите как соединить макросы
Имеется набор который у меня работает как к ниму прицепить ваш макрос?
в комментариях читал ни чего подходящего не нашел((

Private Sub Worksheet_Change(ByVal Target As Range)

Dim lReply As Long

If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("E2")) Is Nothing Then
If IsEmpty(Target) Then Exit Sub
If WorksheetFunction.CountIf(Sheets("ДЛЯ УТС ФОРМУЛА").Range("МОДЕЛЬ"), Target) = 0 Then
lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Worksheets("ДЛЯ УТС ФОРМУЛА").Range("МОДЕЛЬ").Cells(Worksheets("ДЛЯ УТС ФОРМУЛА").Range("МОДЕЛЬ").Rows.Count + 1, 1) = Target
End If
End If
End If
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("L2")) Is Nothing Then
If IsEmpty(Target) Then Exit Sub
If WorksheetFunction.CountIf(Sheets("ДЛЯ УТС ФОРМУЛА").Range("Цвет"), Target) = 0 Then
lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Worksheets("ДЛЯ УТС ФОРМУЛА").Range("Цвет").Cells(Worksheets("ДЛЯ УТС ФОРМУЛА").Range("Цвет").Rows.Count + 1, 1) = Target
End If
End If
End If
Sheets("ДЛЯ УТС ФОРМУЛА").Range("Z2:Z1000").Sort Key1:=Sheets("ДЛЯ УТС ФОРМУЛА").Range("Z2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("ДЛЯ УТС ФОРМУЛА").Range("E2:E1000").Sort Key1:=Sheets("ДЛЯ УТС ФОРМУЛА").Range("E2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("C2"), Target) Is Nothing Then
Application.Run "ad"
End If

If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("E2"), Target) Is Nothing Then
Application.Run "ac"
End If
End Sub

Мир VBA открывает огромные возможности. Вам искренняя благодарность, что помогаете делать нам самостоятельные шаги в этом направлении. С уважением, Холмогоров Андрей.

спасибо, уже разобрался

Добрый день. Рад, что нашел вашу статю - это именно то, что мне нужно. Но моя проблема в том, что я совсем не умею пользоваться макросами.В интернете прочитал как вставить ваш код в модуль листа, но макрос работает некорректно - я что-то перепутал. Если поможете мне - буду благодарен.
Необходимо один столбец закрепить на английский язык, второй столбец - на русский язык. Я скопировал ваш код. В листе Excel, где буду работать вызываю окно редактора VBA (ALT+F11),выбираю нужный файл. Нажимаю Insert, выбираю Module и в появившемся окне модуля листа вставляю ваш код. Закрываю редактор. Сохраняю лист excel в формате xlsm. Открываю этот новый файл, где нужно включить макрос. Здесь возникает затруднение. Выделяю первый столбец. далее Вид - Макросы и в окне выбираю ВключитьАнглийскуюраскладку - Выполнить.Далее выделяю второй столбец - Вид - Макросы - ВключитьРусскуюраскладку - Выполнить. Но увы не работает. Подскажите где моя ошибка.

Да, макросы Worksheet_SelectionChange надо объединить в один.
Объединить, - это не просто поместить друг под другом

Совместить макрос с координатным выделением? зачем???
Ну пусть язык ввода переключился, - вы же все равно не сможете ввести данные в ячейку, поскольку макрос ваш выделяет строку и столбец целиком...
Просто удалите свой макрос, если планируете вводить данные в ячейки, - это самый простой вариант.
Если получаться не будет, - оформляйте заказ на сайте, прикрепив пример файла с кодом.

Вы совершенно верно сказали, все в действительности заработало, вы гений!
Но, я еще один макрос попробовал добавить, как я понял, нужно 2 макроса объединить в один, после объеденения не работает макрос (ActivateKeyboardLayout)
Compile Error: Ambiguous name detected: Worksheet_SelectionChange
В действительности без объединения макросы выглядят так:
Private Declare Function ActivateKeyboardLayout _
Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721

Dim Coord_Selection As Boolean
Sub Selection_On()
Coord_Selection = True
End Sub
Sub Selection_Off()
Coord_Selection = False
End Sub

Private Sub Image1_Click()

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim WorkRange As Range
If Target.Cells.Count > 1 Then Exit Sub
If Coord_Selection = False Then Exit Sub
Application.ScreenUpdating = False
Set WorkRange = Range("A1:S3000")
Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select
Target.Activate
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Select Case Target.Column ' â çàâèñèìîñòè îò íîìåðà ñòîëáöà àêòèâíîé ÿ÷åêè
Case 1 To 3, 6 ' äëÿ ñòîëáöîâ Èìÿ, Ôàìèëèÿ, Íîìåð ìàøèíû, Öâåò
Âêëþ÷èòüÐóññêóþÐàñêëàäêó
Case 4, 5: ' äëÿ ñòîëáöîâ Ìàðêà àâòî, Ìîäåëü
Âêëþ÷èòüÀíãëèéñêóþÐàñêëàäêó
Case Else: ' íè÷åãî íå äåëàåì (îñòàâëÿåì òåêóùóþ ðàñêëàäêó)
End Select
End Sub

Sub Âêëþ÷èòüÐóññêóþÐàñêëàäêó()
' Ïåðåêëþ÷èòü íà ðóññêèé ÿçûê
x = ActivateKeyboardLayout&(kb_lay_ru, 0)
End Sub

Sub Âêëþ÷èòüÀíãëèéñêóþÐàñêëàäêó()
' Ïåðåêëþ÷èòü íà àíãëèéñêèé ÿçûê
x = ActivateKeyboardLayout&(kb_lay_en, 0)
End Sub

Заранее спасибо!

Здравствуйте, Restel.
Надо строку "Private Declare Function ..." вставлять не «где-то в начале модуля»,
а в самом начале модуля (над всеми макросами)
Тогда всё заработает.

Уважаемые, добрый вечер!
Compile error:

Only comments may appear after End Sub, End Function, or End Property

Я прописал код как указан в примере, но, у меня уже есть 2 встроеных макроса в моей книге, при этом я прописываю 3 макрос. После End Sub, End Function или End Property можно вставлять только комментарии.

Я вставил строку "Private Declare Function ..." где-то в Начале модуле

Спасибо,
С уважением.

Решение проблемы, конечно же, есть.
Просто вы что-то не так делаете
(редактор VBA никогда сам не обрезает часть кода)

Сами разобраться не можете если, - всегда есть возможность оформить заказ, прикрепив свои файлы, - и получить готовое решение, работающее во всех версиях Excel в точности так, как вам надо.

так что нет решения проблемы?

Alias "ActivateKeyboardLayout" скрывается после сохранения.

Редактор VBA автоматически укорачивает код???
Что-то новенькое...

Все равно не получается, он его автоматически укорачивает до Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As LongPtr, ByVal flags As Long) As LongPtr
и выдает ошибку constants, fixed-length strings, user-declare statments not allowed as Public members of object modules

Ошибка в типе flags. Правильно (для VBA7):

Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" Alias "ActivateKeyboardLayout" (ByVal HKL As LongPtr, ByVal flags As Long) As LongPtr

Сделал так:

#If VBA7 Then
Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As LongPtr, ByVal flags As LongPtr) As LongPtr
#Else
Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
#End If
Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Select Case Target.Column ' в зависимости от номера столбца активной ячеки
Case 1 To 3, 6 ' для столбцов Имя, Фамилия, Номер машины, Цвет
ВключитьРусскуюРаскладку
Case 4, 5: ' для столбцов Марка авто, Модель
ВключитьАнглийскуюРаскладку
Case Else: ' ничего не делаем (оставляем текущую раскладку)
End Select
End Sub

Sub ВключитьРусскуюРаскладку()
' Переключить на русский язык
x = ActivateKeyboardLayout&(kb_lay_ru, 0)
End Sub

Sub ВключитьАнглийскуюРаскладку()
' Переключить на английский язык
x = ActivateKeyboardLayout&(kb_lay_en, 0)
End Sub

Выдает ошибку на Sub ВключитьРусскуюРаскладку() Compile error: Type-decloration character does not match declared data type

Спасибо

Замените строку

Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long

на строки
#If VBA7 Then
    Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As LongPtr, ByVal flags As LongPtr) As LongPtr
#Else
    Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
#End If

А не подскажете что нужно сделать чтобы все работало на 64 битном офисе 2010 года?

Все получилось, огромное спасибо, очень много полезных советов. я только учусь составлять макросы VBA.
Вот что получилось

Private Declare Function ActivateKeyboardLayout _
                          Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721
 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    ' запрет на ввод русских букв в столбцы 2 и 5
   If Target.Column = 2 Or Target.Column = 5 Then
        If Target Like "*[А-Яа-яЁё]*" Then
            ' если есть хоть одна русская буква
           MsgBox "Ввод русских букв недопустим!", vbCritical
            Target.Value = ""        ' очистка ячейки
       End If
    End If
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Select Case Target.Column    ' в зависимости от номера столбца активной ячеки
       Case 1, 3, 6    ' для столбцов 1, 3, 6
           ВключитьРусскуюРаскладку
        Case 2, 5    ' для столбцов 2, 5
           ВключитьАнглийскуюРаскладку
        Case Else:    ' ничего не делаем (оставляем текущую раскладку)
   End Select
End Sub
 
Sub ВключитьРусскуюРаскладку()
    ' Переключить на русский язык
   x = ActivateKeyboardLayout&(kb_lay_ru, 0)
End Sub
 
Sub ВключитьАнглийскуюРаскладку()
    ' Переключить на английский язык
   x = ActivateKeyboardLayout&(kb_lay_en, 0)
End Sub

по событию Worksheet_Change листа (код добавляете в модуль листа), проверяете номер столбца, и наличие русского текста в изменённой ячейке (Target)

Пример кода:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    ' запрет на ввод русских букв в столбцы 2 и 5
    If Target.Column = 2 Or Target.Column = 5 Then
        If Target Like "*[А-Яа-яЁё]*" Then
            ' если есть хоть одна русская буква
            MsgBox "Ввод русских букв недопустим!", vbCritical
            Target.Value = ""        ' очистка ячейки
        End If
    End If
End Sub

а как реализовать такую проверку после ввода текста?

Чтобы в определенных столбцах включалась нужная раскладка, - можно.
Не поленитесь пролистать комментарии немного вниз, - глядишь, и найдете готовое решение....

А выдавать сообщение при ручном переключении раскладки, - это сложнее.
Макрос будет гораздо сложнее, если надо отлавливать момент смены раскладки.
Куда проще будет проверить введенное в ячейку значение, - и, если оно содержит русские буквы, удалить его, или выдать сообщение об ошибке.
Но, - это сообщение будет выведено не в момент переключения раскладки, а только после завершения ввода текста в ячейку.

и при переходе на русский выдавалась ошибка

привет, а есть такая возможность - сделать так чтобы в определенных столбцах информация вводилась только на английском?

Андрей, в моем коде нет строки Case Intersect(Target, ...) Is Nothing
Так что не работает не мой код, а ваш )

Непонятно, почему вы выбрали диапазон B4:AC4, а в коде задан диапазон B7:U7.
И, если переключение при выделении разных ячеек всё же происходит - значит, код в целом работает. Логично?

У меня ваш код не работает! Если кликать на каждую ячейку то расскладка сама меняестя RUC -ENG. Хотя я выбрал диапазон ячеек B4:AC4.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Select Case False
Case Intersect(Target, [B7:U7]) Is Nothing
ВключитьРусскуюРаскладку

Сделал определение языка на основе последней буквы

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo errorhandler
If UCase(Right(Target.Value, 1)) Like "[A-Z]" Then
english_layout
ElseIf UCase(Right(Target.Value, 1)) Like "[А-Я]" Then
russian_layout
End If

errorhandler: Resume Next
On Error GoTo 0

End Sub

Но не получилось сделать, чтобы все работало с помощью надстройки!
Делал так - в файле добавил модуль, копировал туда весь код (без изменений), сохранял и устанавливал надстройку.
Итог - Private Sub Worksheet_SelectionChange(ByVal Target As Range) не срабатывает.
Подскажи, пжл, точнее, что нужно сделать?

спасибо, попробую!
Еще одна идея - задавать столбцы жестко довольно неудобно, но ведь можно динамически определять на какой языке строка - и от этого играть дальше?
например с помощью цикла по строке и оператора like на принадлежность диапазону букв в языке.

Тогда работа во всех листах + самоопределение текущего языка сделают функцию универсальной.

Да, можно и так сделать.
Но, в этом случае, код нужно будет поместить в надстройку, и реализовать перехват событый выделения ячеек.

Сложность только в том, что для ВСЕХ книг Excel один и тот же алгоритм переключения раскладок вряд ли подойдёт.
Но можно анализировать имена файлов, или путь к ним, и, исходя из этого, включать ту или иную раскладку.

Привет! Скажи, пжл, а можно сделать, чтобы работало во всех листах всех открытых рабочих книг?

Чтобы переключение раскладки клавиатуры работало для определённых диапазонов ячеек,
замените макрос Worksheet_SelectionChange следующим кодом:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Select Case False
        Case Intersect(Target, [a2:b4]) Is Nothing
            ВключитьРусскуюРаскладку ' при выделении ячейки в диапазоне a2:b4
            
        Case Intersect(Target, [e:h]) Is Nothing
            ВключитьАнглийскуюРаскладку ' при выделении ячейки в столбцах с E по H
            
        Case Intersect(Target, [k6:k65000]) Is Nothing
            ВключитьРусскуюРаскладку ' при выделении ячейки в диапазоне k6:k65000
            
        Case Else:    ВключитьАнглийскуюРаскладку ' для остальных ячеек
    End Select
End Sub

А как исправить этот макрос для определенного массива?

Номера раскладок клавиатуры для разных языков:

68748313 - Русская раскладка
67699721 - Английская (США) раскладка
68944924 - Албанская раскладка
67701769 - Английская (Австралия) раскладка
134809609 - Английская (Великобритания) раскладка
403249161 - Английская (Ирландия) раскладка
269029385 - Английская (Канада) раскладка
604578825 - Английская (Карибский) раскладка
67703817 - Английская (Новая Зеландия) раскладка
67705865 - Английская (Южная Африка) раскладка
537468937 - Английская (Ямайка) раскладка
67699766 - Африканская раскладка
70059053 - Бакская раскладка
69403683 - Белорусская раскладка
67240962 - Болгарская раскладка
68027406 - Венгерская раскладка
135464979 - Голландская (Бельгия) раскладка
68355091 - Голландская (стандартная) раскладка
67634184 - Греческая раскладка
67503110 - Датская раскладка
67699745 - Индонезийская раскладка
68092943 - Исландская раскладка
738864138 - Испанская (Аргентина) раскладка
1074413578 - Испанская (Боливия) раскладка
537534474 - Испанская (Венесуэла) раскладка
269094922 - Испанская (Гватемала) раскладка
1208633354 - Испанская (Гондурас) раскладка
470424586 - Испанская (Доминиканская республика) раскладка
604644362 - Испанская (Колумбия) раскладка
336204810 - Испанская (Коста-Рика) раскладка
134875146 - Испанская (Мексиканская) раскладка
1275743242 - Испанская (Никарагуа) раскладка
403314698 - Испанская (Панама) раскладка
1007303690 - Испанская (Парагвай) раскладка
671754250 - Испанская (Перу) раскладка
1342853130 - Испанская (Пуэрто-Рико) раскладка
1141523466 - Испанская (Сальвадор) раскладка
201985034 - Испанская (современная сортировка) раскладка
67765258 - Испанская (традиционная) раскладка
940193802 - Испанская (Уругвай) раскладка
873083914 - Испанская (Чили) раскладка
805974026 - Испанская (Эквадор) раскладка
68158480 - Итальянская (стандартная) раскладка
68159504 - Итальянская (Швейцария) раскладка
67306499 - Каталанский раскладка
69600294 - Латышский раскладка
69665831 - Литовский раскладка
70190127 - Македонский (FYROM) раскладка
67570695 - Немецкая (Австрия) раскладка
67572743 - Немецкая (Линхтейштейн) раскладка
67571719 - Немецкая (Люксембург) раскладка
67568647 - Немецкая (стандартная) раскладка
134678535 - Немецкая (Швейцария) раскладка
68420628 - Норвежская (букмол) раскладка
135530516 - Норвежская (нюнорск) раскладка
68486165 - Польская раскладка
68551702 - Португальская (Бразилия) раскладка
135661590 - Португальская (стандартная) раскладка
68682776 - Румынская раскладка
203033626 - Сербская раскладка
68879387 - Словацкая раскладка
69469220 - Словенская раскладка
69141535 - Турецкая раскладка
69338146 - Украинская раскладка
70779960 - Фарерских островов раскладка
67830795 - Финская раскладка
135006220 - Французская (Бельгия) раскладка
202116108 - Французская (Канада) раскладка
67900428 - Французская (Люксембург) раскладка
67896332 - Французская (стандартная) раскладка
269225996 - Французская (Швейцария) раскладка
68813850 - Хорватская раскладка
67437573 - Чешская раскладка
69010461 - Шведская раскладка
69534757 - Эстонская раскладка

Интересует переключение раскладок для других языков. Где можно посмотреть номера раскладок клавиатур для других языков?

а как тоже самое замутить с capslock'ом

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _   _                _  __         ___  
| \ | | ____ ___ | |/ / ____ / _ \
| \| | |_ / / __| | ' / |_ / | | | |
| |\ | / / | (__ | . \ / / | |_| |
|_| \_| /___| \___| |_|\_\ /___| \__\_\
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.