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

https://excelvba.ru/code/KeyboardLayout#comment-10126

#If VBA7 Then
Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As LongPtr, ByVal flags As Long) As LongPtr
#Else
Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
#End If

Вот универсальный код для 32/64 систем

Yesli mojno mne nado Azerbaydjan LAT kod rasskladka pojalusta.Zaranee sposibo.

Ах, да! Чуть не забыл:
С ДНЕМ ПОБЕДЫ! )

ЗЫ: W10x64, MSoff19x64

Итого, за пять с половиной лет, так и нет ответа на банальный вопрос:

"Гость, 13 Ноя 2013 - 21:21:
А не подскажете что нужно сделать чтобы все работало на 64 битном офисе 2010 года?"

Неужели большинство пользователей работают на х32 ?

"Игорь (администратор сайта), 13 Ноя 2013 - 23:13:
Private Declare PtrSafe Function ActivateKeyboardLayout _
Lib "user32" (ByVal HKL As LongPtr, ByVal flags As LongPtr) As LongPtr"
= ОШИБКА ПРИ ОБРАЩЕНИИ К ФУНКЦИИ

"Владимир, 14 Ноя 2013 - 14:55:
Declare PtrSafe Function ActivateKeyboardLayout _
Lib "user32" Alias "ActivateKeyboardLayout" (ByVal HKL As LongPtr, ByVal flags As Long) As LongPtr"
= ПО ПРЕЖНЕМУ ВЫБРАСЫВАЕТ [Alias "ActivateKeyboardLayout"] И МАТЕРИТСЯ НА ПОСЛЕДНИЙ ПАРАМЕТР (Да-да, Игорь, можно постебаться ещё раз, а можно попробовать вставить строку в VBA на x64)

РЕЗУЛЬТАТ:
вариант 1
ЕСЛИ
Private Declare PtrSafe Function ActivateKeyboardLayout _
Lib "user32" (ByVal HKL As LongPtr, ByVal flags As LongPtr) As LongPtr
ТОГДА
x = ActivateKeyboardLayout(kb_lay_ru, 0)
И
x = ActivateKeyboardLayout(kb_lay_en, 0)
ИТОГ
EN - всё правильно; RU - гоняет по кругу раскладки; UA (например) - не реагирует (ессно, константа, кейс и макрос добавлены)

вариант 2
ЕСЛИ
Private Declare PtrSafe Function ActivateKeyboardLayout& _
Lib "user32" (ByVal HKL As LongPtr, ByVal flags As LongPtr)
ТОГДА
x = ActivateKeyboardLayout&(kb_lay_ru, 0)
И
x = ActivateKeyboardLayout&(kb_lay_en, 0)
ИТОГ
см. вариант 1

ЗЫ: Материал (статья) уже давно протух. Рабочий вариант - через деньги.
ЗЗЫ: Сам давно пользуюсь значением, полученным "х" (в текущем варианте кода) и меняю раскладку по кругу до нужной ... Думал исправить на норм вариант во время "очередной уборки" ) Пока не судьба (

Здравствуйте. Спасибо за макрос, работает. А как бы сделать, что бы, например, в английской расскладке в стобце вводились заглавные буквы автоматически.

Доброе время.Как организовать это в 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. Открываю этот новый файл, где нужно включить макрос. Здесь возникает затруднение. Выделяю первый столбец. далее Вид - Макросы и в окне выбираю ВключитьАнглийскуюраскладку - Выполнить.Далее выделяю второй столбец - Вид - Макросы - ВключитьРусскуюраскладку - Выполнить. Но увы не работает. Подскажите где моя ошибка.

Вы совершенно верно сказали, все в действительности заработало, вы гений!
Но, я еще один макрос попробовал добавить, как я понял, нужно 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

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

Уважаемые, добрый вечер!
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 ..." где-то в Начале модуле

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

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

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

Все равно не получается, он его автоматически укорачивает до 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

Спасибо

А не подскажете что нужно сделать чтобы все работало на 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

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

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

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

У меня ваш код не работает! Если кликать на каждую ячейку то расскладка сама меняестя 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 на принадлежность диапазону букв в языке.

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

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

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

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

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