Каждая буква в отдельной ячейке excel

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

Sub CellEnterFinish(strkey As String)
    ActiveCell.Value = UCase(strkey)
    ActiveCell.Next.Activate
End Sub
 
Sub HookKeys(Str As String, FuncName As String)
    On Error Resume Next
    For i = 1 To Len(Str)
        s = Mid(Str, i, 1)
        Application.OnKey s, "'" & FuncName & """" & s & """'"
    Next
End Sub
 
Sub Макрос1()
'
' Макрос1 Макрос
'
    HookKeys "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя 0123456789-_./QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm", "CellEnterFinish"
 
End Sub

1

Application.OnKey "{" & s & "}", "'" & FuncName & """" & s & """'"

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Dim KeybLayoutName As String
 
Sub CellEnterFinish(strkey As String)
    ActiveCell.Value = UCase(ChangeLang(strkey))
    ActiveCell.Next.Activate
End Sub
 
Function ChangeLang(strkey As String) As String
    Const KEYB_RUS As String = "00000419"
    Const KEYB_ENG As String = "00000409"
    Dim CharsRus As String, CharsEng As String
    CharsRus = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    CharsEng = "F<DULT~:PBQRKVYJGHCNEA{WXIO}SM"">Zf,dult`;pbqrkvyjghcnea[wxio]sm'.z"
    
    KeybLayoutName = String(9, 0)
    GetKeyboardLayoutName KeybLayoutName
    
    Dim i As Integer
    Dim LangRus As Boolean
    LangRus = (StrComp(KeybLayoutName, KEYB_RUS, vbTextCompare) = 0)
    If LangRus Then
        i = InStr(CharsEng, strkey)
    Else
        i = InStr(CharsRus, strkey)
    End If
    If i = 0 Then
        ChangeLang = strkey
        Exit Function
    End If
    If LangRus Then
        ChangeLang = Mid(CharsRus, i, 1)
    Else
        ChangeLang = Mid(CharsEng, i, 1)
    End If
End Function
 
Sub HookKeys(Str As String, FuncName As String)
    On Error Resume Next
    For i = 1 To Len(Str)
        s = Mid(Str, i, 1)
        Application.OnKey s, "'" & FuncName & """" & s & """'"
    Next
End Sub
 
Sub Макрос1()
Attribute Макрос1.VB_ProcData.VB_Invoke_Func = " n14"
'
' Макрос1 Макрос
'
    HookKeys "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя 0123456789-_./QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm", "CellEnterFinish"
 
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14

Private Sub Workbook_Open()
    НВР_ХРУЩ_ОднаБукваВКаждойЯчейке
    If range("F76").Value = "" Or range("F76").Value = " " Then
        range("F76").Value = Mid(Date, 1, 1)
        range("G76").Value = Mid(Date, 2, 1)
        range("I76").Value = Mid(Date, 4, 1)
        range("J76").Value = Mid(Date, 5, 1)
        range("L76").Value = Mid(Date, 7, 1)
        range("M76").Value = Mid(Date, 8, 1)
        range("N76").Value = Mid(Date, 9, 1)
        range("O76").Value = Mid(Date, 10, 1)
    End If
    range("L3").Activate
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Dim KeybLayoutName As String
 
Const HOOKED_KEYS As String = "f,dult`;pbqrkvyjghcnea[wxio]sm'.z 0123456789@-_/"
 
Function InRange(Target As range, RangeIn As range) As Boolean
    InRange = Not Intersect(Target, RangeIn) Is Nothing
End Function
 
Function CaseRanges(strkey As String) As String
    If (InRange(ActiveCell, range("A32:AP34"))) Then
        CaseRanges = strkey
        Exit Function
    End If
    If (InRange(ActiveCell, range("38:46, 55:66")) And strkey <> " ") Then
        CaseRanges = "X"
        Exit Function
    End If
    CaseRanges = UCase(strkey)
End Function
 
Function ChangeLang(strkey As String) As String
    Const KEYB_RUS As String = "00000419"
    Const KEYB_ENG As String = "00000409"
    Dim CharsRus As String, CharsEng As String
    CharsRus = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    CharsEng = "F<DULT~:PBQRKVYJGHCNEA{WXIO}SM"">Zf,dult`;pbqrkvyjghcnea[wxio]sm'.z"
    
    KeybLayoutName = String(9, 0)
    GetKeyboardLayoutName KeybLayoutName
    
    Dim i As Integer
    Dim LangRus As Boolean
    LangRus = (StrComp(KeybLayoutName, KEYB_RUS, vbTextCompare) = 0)
    If LangRus Then
        i = InStr(CharsEng, strkey)
    Else
        i = InStr(CharsRus, strkey)
    End If
    If i = 0 Then
        ChangeLang = strkey
        Exit Function
    End If
    If LangRus Then
        ChangeLang = Mid(CharsRus, i, 1)
    Else
        ChangeLang = Mid(CharsEng, i, 1)
    End If
End Function
 
Sub CellEnterFinish(keycode As Integer)
'    On Error Resume Next
    strkey = CaseRanges(ChangeLang(Chr(keycode)))
    If Not ActiveCell.AllowEdit Then ActiveCell.Next.Activate
    ActiveCell.Value = strkey
    ActiveCell.Next.Activate
End Sub
 
Sub HookKeys(Str As String, FuncName As String)
'   On Error Resume Next
    For i = 1 To Len(Str)
        s = Mid(Str, i, 1)
        If Not IsNumeric(s) Then
            Application.OnKey "{" & s & "}", "'" & FuncName & """" & Asc(s) & """'"
        Else
            sx = CInt(s) + 96
            Application.OnKey s, "'" & FuncName & """" & Asc(s) & """'"
            Application.OnKey "{" & sx & "}", "'" & FuncName & """" & Asc(s) & """'"
        End If
    Next
End Sub
 
Sub UnHookKeys(Str As String)
'    On Error Resume Next
    For i = 1 To Len(Str)
        s = Mid(Str, i, 1)
        If Not IsNumeric(s) Then
            Application.OnKey "{" & s & "}"
        Else
            sx = CInt(s) + 96
            Application.OnKey s
            Application.OnKey "{" & sx & "}"
        End If
    Next
End Sub
 
Private Sub RemovePrev()
'    On Error Resume Next
    If ActiveCell.Value <> "" And ActiveCell.Value <> " " Then
        ActiveCell.Value = ""
        Exit Sub
    End If
    ActiveCell.Previous.Activate
    ActiveCell.Value = ""
End Sub
 
Sub НВР_ХРУЩ_ОднаБукваВКаждойЯчейке()
'    On Error Resume Next
    HookKeys HOOKED_KEYS, "CellEnterFinish"
    Application.OnKey "{BACKSPACE}", "RemovePrev"
    Application.OnKey "{TAB}"
End Sub
 
Private Sub Auto_Close()
    UnHookKeys HOOKED_KEYS
    Application.OnKey "{BACKSPACE}"
End Sub

1
2

CharsRus = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя."
CharsEng = "F<DULT~:PBQRKVYJGHCNEA{WXIO}SM"">Zf,dult`;pbqrkvyjghcnea[wxio]sm'.z/"

1

Application.OnKey "+{" & s & "}", "'" & FuncName & """" & Asc(s) & """'"

1
2
3
4
5
6
7

Private Sub NextLine()
    Dim i As Long
    i = ActiveCell.Row
    Do While ActiveCell.Row = i
        ActiveCell.Next.Select
    Loop
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Dim KeybLayoutName As String
 
Const HOOKED_KEYS As String = "f,dult`;pbqrkvyjghcnea[wxio]sm'.z 0123456789@-_/"
 
Function InRange(Target As range, RangeIn As range) As Boolean
    InRange = Not Intersect(Target, RangeIn) Is Nothing
End Function
 
Function CaseRanges(strkey As String) As String
    If (InRange(ActiveCell, range("A32:AP34"))) Then
        CaseRanges = strkey
        Exit Function
    End If
    If (InRange(ActiveCell, range("38:46, 55:66")) And strkey <> " ") Then
        CaseRanges = "X"
        Exit Function
    End If
    CaseRanges = UCase(strkey)
End Function
 
Function ChangeLang(strkey As String) As String
    Const KEYB_RUS As String = "00000419"
    Const KEYB_ENG As String = "00000409"
    Dim CharsRus As String, CharsEng As String
    CharsRus = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    CharsEng = "F<DULT~:PBQRKVYJGHCNEA{WXIO}SM"">Zf,dult`;pbqrkvyjghcnea[wxio]sm'.z"
    
    KeybLayoutName = String(9, 0)
    GetKeyboardLayoutName KeybLayoutName
    
    Dim i As Integer
    Dim LangRus As Boolean
    LangRus = (StrComp(KeybLayoutName, KEYB_RUS, vbTextCompare) = 0)
    If LangRus Then
        i = InStr(CharsEng, strkey)
    Else
        i = InStr(CharsRus, strkey)
    End If
    If i = 0 Then
        If LangRus And strkey = "/" Then
            ChangeLang = "."
        Else
            ChangeLang = strkey
        End If
        Exit Function
    End If
    If LangRus Then
        ChangeLang = Mid(CharsRus, i, 1)
    Else
        ChangeLang = Mid(CharsEng, i, 1)
    End If
End Function
 
Sub CellEnterFinish(keycode As String)
    On Error Resume Next
    Dim shift As Boolean
    shift = Left(keycode, 1) = "s" ' для поддержки заглавных букв в таких полях, как email, skype и т.п.
    If shift Then keycode = Mid(keycode, 2)
    strkey = CaseRanges(ChangeLang(Chr(keycode)))
    If shift Then strkey = UCase(strkey)
    If Not ActiveCell.AllowEdit Then ActiveCell.Next.Activate
    ActiveCell.Value = strkey
    ActiveCell.Next.Activate
End Sub
 
Sub HookKeys(Str As String, FuncName As String)
    On Error Resume Next
    For i = 1 To Len(Str)
        s = Mid(Str, i, 1)
        If Not IsNumeric(s) Then
            Application.OnKey "{" & s & "}", "'" & FuncName & """" & Asc(s) & """'"
            If Not InStr("!@#$%^&*()_+~|", s) Then
                Application.OnKey "+{" & s & "}", "'" & FuncName & """s" & Asc(s) & """'"
            End If
        Else
            sx = CInt(s) + 96
            Application.OnKey s, "'" & FuncName & """" & Asc(s) & """'"
            Application.OnKey "{" & sx & "}", "'" & FuncName & """" & Asc(s) & """'"
        End If
    Next
End Sub
 
Sub UnHookKeys(Str As String)
    On Error Resume Next
    For i = 1 To Len(Str)
        s = Mid(Str, i, 1)
        If Not IsNumeric(s) Then
            Application.OnKey "{" & s & "}"
        Else
            sx = CInt(s) + 96
            Application.OnKey s
            Application.OnKey "{" & sx & "}"
        End If
    Next
End Sub
 
Private Sub RemovePrev()
    On Error Resume Next
    If ActiveCell.Value <> "" And ActiveCell.Value <> " " Then
        ActiveCell.Value = ""
        Exit Sub
    End If
    ActiveCell.Previous.Activate
    ActiveCell.Value = ""
End Sub
 
Private Sub GoToNextField()
    Dim next_cell_x As Integer
    next_cell_x = ActiveCell.Column + 1
    While ActiveCell.Column + 1 = next_cell_x
        ActiveCell.Next.Activate
        next_cell_x = next_cell_x + 1
    Wend
End Sub
 
Sub НВР_ХРУЩ_ОднаБукваВКаждойЯчейке()
    On Error Resume Next
    HookKeys HOOKED_KEYS, "CellEnterFinish"
    Application.OnKey "{BACKSPACE}", "RemovePrev"
    Application.OnKey "{ENTER}", "GoToNextField"
    Application.OnKey "~", "GoToNextField"
    Application.OnKey "{TAB}"
End Sub
 
Private Sub Auto_Close()
    UnHookKeys HOOKED_KEYS
    Application.OnKey "{BACKSPACE}"
    Application.OnKey "{ENTER}"
    Application.OnKey "~"
End Sub