Страницы: 1
RSS
Контроль ввода ФИО
 
Подскажите как можно контролировать ввод ФИО в ячейку чтобы вводились данные как в примере Иванов И.И
1-я Большая буква
2-я Пробел после фамилии
3-я Имя большая буква
4-я Точка
5-я Большая буква Отчество
А не иванов и.и, ИвановИИ...
 
так и проверить примерно так
=REPLACE(REPLACE(PROPER(SUBSTITUTE(A1;".";" "));LEN(A1)-1;1;".");LEN(A1)-3;1;" ")=A1
По вопросам из тем форума, личку не читаю.
 
Благодарю но мне нужно контролировать именно ввод, а не проверить заполнение. Когда будут вводить ФИО
 
Сделать форму для ввода
 
Вот код, который преобразовывает значение ячейки в соответствие с регистром после ввода

Подправил код, думаю, так правильнее.

В модуль листа:

Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, myArr()
Dim CharVariable As Integer, SpaceVariable As Integer

If Target = "" Then Exit Sub

SpaceVariable = FindLettersAfterSpace(Target)
CharVariable = FindSpaces(Target)

If CharVariable > 1 Or CharVariable = 0 Or SpaceVariable <> 3 _
Or ПроверкаИнициаловНаНаличиеТочки(Target) = False Then
MsgBox "Вводите инициалы через точку!!!"
Target.ClearContents
Exit Sub
End If

ReDim myArr(1 To Len(Target))


For i = 1 To Len(Target)
myArr(i) = Mid(Target, i, 1)
Next

For i = LBound(myArr) To UBound(myArr)
    If i = 1 Then myArr(1) = UCase(myArr(1))
    If i = UBound(myArr) - 1 Then myArr(UBound(myArr)) = UCase(myArr(UBound(myArr)))
    If i = UBound(myArr) - 1 Then myArr(UBound(myArr) - 2) = UCase(myArr(UBound(myArr) - 2))
Next
Target = Join(myArr, "")
End Sub

В отдельный модуль функции:

Код
Function FindSpaces(CharVariable As Range) As Integer
Dim i, myCounter, myVar As String
myCounter = 0
myVar = RTrim(CStr(CharVariable))
For i = 1 To Len(myVar)
If Mid(myVar, i, 1) = " " Then myCounter = myCounter + 1
Next
FindSpaces = myCounter
End Function

Function FindLettersAfterSpace(myRange As Range) As Integer
Dim i, k, myVar As String, Letter As Integer
Letter = 0
myVar = RTrim(CStr(myRange))
For i = 1 To Len(myVar)
If Mid(myVar, i, 1) = " " Then
    For k = 1 To Len(Mid(myVar, InStr(1, myVar, " "), Len(myVar)))
    Letter = k - 1
    Next k
    Exit For
    End If
Next
FindLettersAfterSpace = Letter
End Function

Function ПроверкаИнициаловНаНаличиеТочки(myRange As Range) As Boolean
Dim i, Letter As Integer
Dim newString As String

newString = Mid(myRange, InStr(1, myRange, " "), Len(myRange))

If Mid(newString, 3, 1) <> "." Then
ПроверкаИнициаловНаНаличиеТочки = False
Else
ПроверкаИнициаловНаНаличиеТочки = True
End If
End Function
Изменено: artemkau88 - 01.04.2021 20:42:59
 
Цитата
Андрей_26 написал:
Сделать форму для ввода
Форма не подходит по ряду причин
 
Назовите хоть одну ? По другому думаю не возможно, потому что нельзя предусмотреть все варианты написания, которые придумает пользователь.
 
Ян Копко, попробуйте "тупой" метод по положению символов в тексте (можно еше пройтись по каждому символу и проверить их регистр)
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A6")) Is Nothing Then
    x = Left(Target, 1)
    x2 = Mid(Target, Len(Target) - 1, 1)
    x3 = Mid(Target, Len(Target) - 2, 1)
    x4 = Mid(Target, Len(Target) - 3, 1)
    x5 = Mid(Target, Len(Target), 1)
    If x = LCase(x) Or x2 <> "." Or x3 = LCase(x3) Or x4 <> " " Or x5 = LCase(x5) Then
        MsgBox "ÔÈÎ ÓÊÀÇÀÍÎ ÍÅÂÅÐÍÎ! ÏÎÂÒÎÐÈÒÅ ÂÂÎÄ"
        Target.Interior.ColorIndex = 3
    Else
        Target.Interior.ColorIndex = xlNone
    End If
End If
End Sub

Не бойтесь совершенства. Вам его не достичь.
 
Хотя вроде работает)
Изменено: Андрей_26 - 28.03.2021 16:46:28
 
Андрей_26, ну да на конце еще можно
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A6")) Is Nothing Then
    x = Left(Target, 1)
    x2 = Mid(Target, Len(Target) - 1, 1)
    x3 = Mid(Target, Len(Target) - 2, 1)
    x4 = Mid(Target, Len(Target) - 3, 1)
    x5 = Mid(Target, Len(Target), 1)
    x6 = Mid(Target, Len(Target) - 4, 1)
    If x = LCase(x) Or x2 <> "." Or x3 = LCase(x3) Or x4 <> " " Or x5 = LCase(x5) Or x6 = LCase(x5) Then
        MsgBox "ФИО УКАЗАНО НЕВЕРНО! ПОВТОРИТЕ ВВОД"
        Target.Interior.ColorIndex = 3
    Else
        Target.Interior.ColorIndex = xlNone
    End If
End If
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Ян Копко написал:
мне нужно контролировать именно ввод,
что под этим подразумевается? Исправлять, не давать ввести? Если последнее, то проверка данных с моей формулой.
По вопросам из тем форума, личку не читаю.
 
Благодарю Вас Всех, Ваши коди подошли.
Изменено: Ян Копко - 28.03.2021 17:14:16
Страницы: 1
Наверх