Алгоритм проверки снилс excel

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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377

Option Explicit
 
Const c1 = "алан.александр.алексей.альберт.анатолий.андрей.антон.арсен.арсений.артем.артемий.артур.богдан.борис.вадим.валентин.валерий.василий.виктор.виталий.владимир.владислав.всеволод.вячеслав.геннадий.георгий.герман.глеб.гордей.григорий.давид.дамир.даниил.демид.демьян.денис.дмитрий.евгений.егор.елисей.захар.иван.игнат.игорь.илья.ильяс.камиль.карим.кирилл.клим.константин.лев.леонид.макар.максим.марат.марк.марсель.матвей.мирон.мирослав.михаил.назар.никита.николай.олег.павел.петр.платон.прохор.рамиль.ратмир.ринат.роберт.родион.роман.ростислав.руслан.рустам.савва.савелий.святослав.семен.сергей.станислав.степан.тамерлан.тимофей.тимур.тихон.федор.филипп.шамиль.эдуард.эльдар.эмиль.эрик.юрий.ян.ярослав"
Const c2 = "агата.агния.аделина.аида.аксинья.александра.алена.алина.алиса.алия.алла.альбина.амелия.амина.анастасия.ангелина.анна.антонина.ариана.арина.валентина.валерия.варвара.василина.василиса.вера.вероника.виктория.виолетта.владислава.галина.дарина.дарья.диана.дина.ева.евангелина.евгения.екатерина.елена.елизавета.есения.жанна.зарина.злата.илона.инна.ирина.камилла.карина.каролина.кира.клавдия.кристина.ксения.лариса.лейла.лиана.лидия.лилия.лина.лия.любовь.людмила.майя.маргарита.марианна.марина.мария.мелания.мила.милана.милена.мирослава.надежда.наталья.нелли.ника.нина.оксана.олеся.ольга.полина.регина.сабина.светлана.софия.стефания.таисия.тамара.татьяна.ульяна.эвелина.элина.эльвира.эльмира.эмилия.юлия.яна.ярослава"
Const c3 = "александрович.алексеевич.анатольевич.андреевич.антонович.аркадьевич.артемович.бедросович.богданович.борисович.валентинович.валерьевич.васильевич.викторович.витальевич.владимирович.владиславович.вольфович.вячеславович.геннадиевич.георгиевич.григорьевич.данилович.денисович.дмитриевич.евгеньевич.егорович.ефимович.иванович.иваныч.игнатьевич.игоревич.ильич.иосифович.исаакович.кириллович.константинович.леонидович.львович.максимович.матвеевич.михайлович.николаевич.олегович.павлович.палыч.петрович.платонович.робертович.романович.саныч.северинович.семенович.сергеевич.станиславович.степанович.тарасович.тимофеевич.федорович.феликсович.филиппович.эдуардович.юрьевич.яковлевич.ярославович"
Const c4 = "александровна.алексеевна.анатольевна.андреевна.антоновна.аркадьевна.артемовна.богдановна.борисовна.валентиновна.валерьевна.васильевна.викторовна.виталиевна.владимировна.владиславовна.вячеславовна.геннадиевна.георгиевна.григорьевна.даниловна.денисовна.дмитриевна.евгеньевна.егоровна.ефимовна.ивановна.игоревна.ильинична.иосифовна.кирилловна.константиновна.леонидовна.львовна.максимовна.матвеевна.михайловна.николаевна.олеговна.павловна.петровна.платоновна.робертовна.романовна.семеновна.сергеевна.станиславовна.степановна.тарасовна.тимофеевна.федоровна.феликсовна.филипповна.эдуардовна.юрьевна.яковлевна.ярославовна"
Const c5 = "абрамов.александров.алексеев.андреев.антонов.афанасьев.баранов.белов.беляев.богданов.борисов.быков.васильев.виноградов.власов.волков.воробьев.воронин.гаврилов.герасимов.голубев.григорьев.гусев.давыдов.данилов.денисов.дмитриев.егоров.ефимов.жуков.зайцев.захаров.иванов.ильин.исаев.казаков.калинин.карпов.киселев.климов.ковалев.козлов.комаров.коновалов.королев.крылов.кудрявцев.кузнецов.кузьмин.куликов.лазарев.лебедев.макаров.максимов.марков.мартынов.маслов.матвеев.медведев.мельников.миронов.михайлов.морозов.назаров.никитин.николаев.новиков.орлов.осипов.павлов.петров.поляков.пономарев.попов.прохоров.родионов.романов.савельев.семенов.сергеев.сидоров.смирнов.соколов.соловьев.сорокин.степанов.тарасов.тимофеев.титов.тихонов.федоров.федотов.филатов.филиппов.фомин.фролов.чернов.чернышев.щербаков.яковлев"
Const frmSnils = "000-000-000 00", frmINN10 = "0000-00000-0", frmINN12 = "0000-000000-00"
Const inn10 = "2 4 10 3 5 9 4 6 8", inn12_1 = "7 2 4 10 3 5 9 4 6 8", inn12_2 = "3 7 2 4 10 3 5 9 4 6 8"
 
#If Win64 Then
   Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
   Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
 
Dim WithEvents Tx As MSForms.TextBox, WithEvents cb As MSForms.CommandButton
Dim WithEvents cbb1 As CommandBarButton, WithEvents cbb2 As CommandBarButton
Dim colCueBan As New Collection
 
 
 
Function OnlyNum$(ByVal text$)
        Dim i&
        'Возврат всех чисел из текста
        For i = 1 To Len(text)
            If Mid$(text, i, 1) Like "#" Then OnlyNum = OnlyNum & Mid$(text, i, 1)
        Next
End Function
 
 
Private Sub tx_LostFocus(objLost As Object, Got$)
 
    Dim s$, ss$, Filtr$, i&, j&, d#, a$(), v, InpErr As Boolean
 
    If Got = "cb7" Then Exit Sub 'Для всех полей игнорируется кнопка "Очистить все"
    
    
    If Got Like "cb#*" Then
        Select Case Got
        Case "cb11", "cb12" 'Проверка ввода если фокус переведен на эти кнопки
        Case Else: Exit Sub 'Проверка не нужна
        End Select
    End If
    
    s = objLost.text
    If s = "" Then Exit Sub
    
    Select Case objLost.Name
    Case "tx1" 'Проверка ФИО
 
        s = LCase(s)
        'Находим первый алфавитый символ
        For i = 1 To Len(s)
            If Mid$(s, i, 1) Like "[a-zа-яё]" Then Exit For
        Next: s = Mid$(s, i)
       
 
        'Убираем передний пробел у точки и добавляем его справа
        While InStr(s, " .") > 0: s = Replace(s, " .", "."): Wend: s = Replace(s, ".", ". ")
        'Убираем лишние пробелы
        s = Trim(s): While InStr(s, "  ") > 0: s = Replace(s, "  ", " "): Wend
        'Объеденяем слова с дефисом
        s = Replace(Replace(s, "- ", "-"), " -", "-")
        'Проверка расстановки знаков
        InpErr = InpErr Or InStr(s, "-.") Or InStr(s, ".-")
        'Проверка написания в одной расскладке
 
        ss = Replace(Replace(Replace(s, ".", ""), "-", ""), " ", "")
        If Len(ss) >= 3 Then
            If Left(ss, 1) Like "[!a-zа-яё]" Then
                InpErr = True
            Else
                Filtr = IIf(Left(ss, 1) Like "[a-z]", "[!a-z]", "[!а-яё]")
                For i = 2 To Len(ss)
                    If Mid$(ss, i, 1) Like Filtr Then InpErr = True: Exit For
                Next
            End If
        Else: InpErr = True
        End If
        'Каждое слово с большой буквы
        a = Split(s, "-"): For i = 0 To UBound(a): a(i) = UCase(Left$(a(i), 1)) & Mid$(a(i), 2): Next: s = Join(a, "-") 'Между дефисом
        a = Split(s): For i = 0 To UBound(a): a(i) = UCase(Left$(a(i), 1)) & Mid$(a(i), 2): Next: s = Join(a) 'Между пробелом
        
        'Проверка трех слов ФИО
        InpErr = InpErr Or UBound(a) <> 2
        If InpErr Then MsgValidate objLost, "Неверный ввод ФИО/Текст должен иметь одну расскладку/без специальных знаков и цифр,/состоять из трех отдельных слов./Допускается дефис и точка": Exit Sub
        objLost.text = s
    Case "tx2" 'Проверка Даты
        If IsDate(objLost.text) Then
            objLost.text = CDate(s)
        Else
            If InpErr Then MsgValidate objLost, "Неверная дата или формат даты/Допустимые форматы: /[дата.месяц.год]  [дата/месяц/год]  [дата.месяц]/[дата-месяц-год]  [1 янв 2019] "
        End If
    Case "tx3" 'Проверка СНИЛС
        s = OnlyNum(s): d = 0
        If Len(s) <> 11 Then
            InpErr = True
        ElseIf CDbl(s) < 1001999 Then
            InpErr = True
        Else
            For i = 1 To 9: d = d + (10 - i) * Mid$(s, i, 1): Next
            If Format((d Mod 101) Mod 100, "00") <> Right$(s, 2) Then InpErr = True
        End If
        If InpErr Then MsgValidate objLost, "Неверный ввод СНИЛС/Необходимо ввести 11 цифр./Требуется совпадение контрольной суммы.": Exit Sub
        SetText objLost, s, frmSnils
        
    Case "tx4" 'Проверка ИНН
        s = OnlyNum(s)
        If Len(s) = 10 Then 'Расчет для юр-лиц
            a = Split(inn10): d = 0
            For i = 0 To UBound(a)
                d = d + a(i) * Mid$(s, i + 1, 1)
            Next
            If ((d Mod 11) Mod 10) <> Mid$(s, i + 1, 1) Then InpErr = True
            
        ElseIf Len(s) = 12 Then 'Расчет для физ-лиц
            For j = 1 To 2
                a = Split(Choose(j, inn12_1, inn12_2)): d = 0
                For i = 0 To UBound(a)
                    d = d + a(i) * Mid$(s, i + 1, 1)
                Next
                If ((d Mod 11) Mod 10) <> Mid$(s, i + 1, 1) Then InpErr = True
            Next
        End If
        If InpErr Then MsgValidate objLost, "Неверный ИНН/Для юридических лиц 10 цифр, для физических 12./Требуется совпадение контрольной суммы.": Exit Sub
    End Select
    
End Sub
 
Sub SetText(Tx As Object, text$, Optional ByVal TxFormat$)
    If text = "" Then Exit Sub
    With Tx
        .text = Format(text, TxFormat)
        .ForeColor = vbWindowText
    End With
End Sub
 
Sub Any_Click(ByVal DesText$)
    Dim s$, i&, j&, d#, v, b As Boolean
    Randomize Timer
    Select Case DesText
    Case "cb1_1", "cb1_2" 'Генерация ФИО
        b = DesText = "cb1_1"
        v = IIf(b, Array(c5, c1, c3), Array(c5, c2, c4))
        For i = 0 To UBound(v)
            v(i) = Split(v(i), ".")
            s = s & " " & v(i)(Fix(Rnd * (UBound(v(i)) + 1)))
        Next
        v = Split(Mid$(s, 2))
        For i = 0 To UBound(v)
            If i = 0 And Not b Then v(i) = v(i) & "а"
            v(i) = UCase(Left$(v(i), 1)) & Mid$(v(i), 2)
        Next
        SetText Controls("tx1"), Join(v)
    Case "cb2" '--------------Генерация даты с 1900 по 2019 годов
        SetText Controls("tx2"), CDate(Fix(Rnd * 43465) + 2)
    Case "cb3" 'Генерация СНИЛС
        s = Space(11): d = 0
        For i = 1 To 9
            j = IIf(i = 2, Fix(Rnd * 9) + 1, Fix(Rnd * 10))
            Mid$(s, i, 1) = j
            d = d + (10 - i) * j
        Next
        Mid$(s, i, 2) = Format(((d Mod 101) Mod 100), "00")
        SetText Controls("tx3"), s, frmSnils
    Case "cb4_1", "cb4_2" 'Генерация ИНН
        If DesText = "cb4_1" Then
            s = Space(12)
            v = Split(inn12_1): d = 0
            For i = 1 To 10
                j = IIf(i = 2, Fix(Rnd * 9) + 1, Fix(Rnd * 10))
                Mid$(s, i, 1) = j
                d = d + v(i - 1) * j
            Next
            Mid$(s, i, 1) = (d Mod 11) Mod 10
            v = Split(inn12_2): d = 0
            For i = 1 To 11
                d = d + v(i - 1) * Mid$(s, i, 1)
            Next
            Mid$(s, i, 1) = (d Mod 11) Mod 10
        Else
            s = Space(10)
            v = Split(inn10): d = 0
            For i = 1 To 9
                j = IIf(i = 2, Fix(Rnd * 9) + 1, Fix(Rnd * 10))
                Mid$(s, i, 1) = j
                d = d + v(i - 1) * j
            Next
            Mid$(s, i, 1) = (d Mod 11) Mod 10
        End If
        SetText Controls("tx4"), s, IIf(DesText = "cb4_1", frmINN12, frmINN10)
    Case "cb11" '-------------------------Вывод на лист"
        With ActiveSheet '----------Здесь можно назначить свой лист напр. Sheet("Лист1")
            i = .Cells(.Rows.Count, 1).End(xlUp).Row
            If i = 1 Then
                j = 0: For Each v In Controls
                    If v.Name Like "tx#*" Then
                        j = j + 1: With .Cells(i, j)
                            .Font.Bold = True
                            .HorizontalAlignment = xlCenter
                            .Value = colCueBan(v.Name)
                            .CurrentRegion.EntireColumn.AutoFit
                        End With
                    End If
                Next
            End If
            j = 0: For Each v In Controls
                If v.Name Like "tx#*" Then
                    j = j + 1: With .Cells(i + 1, j)
                        If v.ForeColor = vbWindowText Then
                            .Value = v.text
                            .CurrentRegion.EntireColumn.AutoFit
                        End If
                    End With
                End If
            Next
        End With
    Case "cb12" 'Копирование"
        
        For Each v In Controls
            If v.Name Like "tx#*" Then
                If v.ForeColor = vbWindowText Then
                    s = s & vbLf & colCueBan(v.Name) & vbTab & v.text
                End If
            End If
        Next
        With New DataObject
            .Clear
            .SetText Mid$(s, 2)
            .PutInClipboard
        End With
        
    Case "cb13" 'Очистить все"
        For Each v In Controls
            If v.Name Like "tx#*" Then v.text = ""
        Next
        CheckBaner
    End Select
End Sub
 
 
 
Private Sub cbb1_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    Any_Click Ctrl.DescriptionText
End Sub
 
Private Sub cbb2_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    Any_Click Ctrl.DescriptionText
End Sub
 
 
Private Sub cb_Click()
    Dim v, i&, j&
    Select Case cb.Name
    Case "cb1", "cb4"
        On Error Resume Next
        Application.CommandBars("mnu").Delete
        With Application.CommandBars.Add("mnu", msoBarPopup)
            For i = 1 To 2
                
                With .Controls.Add(msoControlButton)
                    Select Case cb.Name
                    Case "cb1": .Caption = Choose(i, "Мужчина", "Женщина")
                    Case "cb4": .Caption = Choose(i, "Физ. лицо", "Юр. лицо")
                    End Select
                    .FaceId = 59
                    .DescriptionText = cb.Name & "_" & i
                End With
            Next
            Set cbb1 = .Controls(1)
            Set cbb2 = .Controls(2)
            If Application.WindowState = xlMinimized Then Any_Click cb.Name & "_" & 1 Else .ShowPopup
 
        End With
 
    Case Else 'Прочие кнопки без меню
        Any_Click cb.Name
    End Select
End Sub
 
 
Private Sub MsgValidate(obj As Object, ByVal text$, Optional ByVal buttons = vbExclamation, Optional ByVal delemiter = "/")
    '
    'Вывод сообщений
    '
    obj.SetFocus
    MsgBox Replace(text, delemiter, vbLf), buttons
End Sub
 
Private Sub CheckBaner()
    Dim Focus$, v
    Focus = ActiveControl.Name
    For Each v In Controls
        If v.Name Like "tx#*" Then
            If v.text = "" And v.Name <> Focus Then
                v.ForeColor = vb3DShadow
                v.text = colCueBan(v.Name)
            ElseIf v.ForeColor = vb3DShadow And v.Name = Focus Then
                v.ForeColor = vbWindowText
                v.text = ""
            End If
        End If
    Next
End Sub
 
Private Sub NewFocus(ByVal Lost$, ByVal Got$)
    
    If Got Like "tx#*" Then
        Set Tx = Controls(Got)
        Tx.SetFocus
    ElseIf Got Like "cb#*" Then
         Set cb = Controls(Got)
    End If
    If Lost Like "tx#*" Then
        tx_LostFocus Controls(Lost), Got
    End If
    CheckBaner
End Sub
 
 
 
 
Private Sub UserForm_Activate()
    Dim curCtrl$
    curCtrl = ActiveControl.Name
    Controls("cb1").SetFocus
    CheckBaner
    Do: DoEvents: Sleep 10
        If curCtrl <> ActiveControl.Name Then _
        NewFocus curCtrl, ActiveControl.Name: curCtrl = ActiveControl.Name
    Loop
End Sub
 
Private Sub UserForm_Initialize()
    Const r = 7, tp = 4, fields = 4
    Dim i&, j&, ctProgId$, ctName$, cLeft&, ctWidth&, s$
    
    For i = 1 To fields
        cLeft = r
        For j = 1 To 2
            ctProgId = "forms." & Choose(j, "textbox", "commandbutton") & ".1"
            ctName = Choose(j, "tx", "cb") & i
            ctWidth = Choose(j, r * 30, r * 4)
            With Controls.Add(ctProgId, ctName, 1)
                .Move cLeft, (i - 1) * r * tp + r, ctWidth, r * (tp - 1)
                s = Choose(i, "ФИО", "Дата рождения", "СНИЛС", "ИНН")
                If .Name Like "tx#*" Then
                    colCueBan.Add s, .Name
                ElseIf .Name Like "cb#*" Then
                    .Caption = "G"
                    .ControlTipText = "Сгенерировать " & s
                End If
                cLeft = cLeft + .Width + r
            End With
        Next
    Next
    
    cLeft = r
    For j = 1 To 3
        ctWidth = r * 10
        With Controls.Add("forms.commandbutton.1", "cb" & 10 + j, 1)
            .Move cLeft, (i - 1) * r * tp + r, ctWidth, r * (tp - 1)
            .Caption = Choose(j, "Вывести на лист", "Копировать", "Очистить все")
            cLeft = cLeft + .Width + r
        End With
    Next
    With Me
         .Move .Left, .Top, r * 40, r * 26
         .Caption = "Ввод данных"
    End With
 
End Sub
 
Private Sub UserForm_Terminate()
    End
End Sub