Option Explicit

' СОТик: подготовка штатки к импорту сотрудников.
' 1. Откройте выгрузку в настольном Excel.
' 2. Нажмите Alt+F11, выберите Insert -> Module и вставьте весь этот файл.
' 3. Вернитесь в Excel, нажмите Alt+F8 и запустите NormalizeStaffTableForSotik.
' Макрос создаёт новый нормализованный лист. Исходный лист не изменяется.

' Макрос для "групповой" штатки (подразделение строкой, ниже список сотрудников).
' Переносит название подразделения в отдельный столбец "Подразделение",
' затем выполняет полную нормализацию (порядок столбцов, даты, СНИЛС, форматирование, фильтр, сортировка).

Public Sub NormalizeStaffTableForSotik()
    NormalizeStaffTableGrouped2
End Sub

Public Sub NormalizeStaffTableGrouped2()
    Dim sourceWs As Worksheet
    Dim ws As Worksheet
    Set sourceWs = ActiveSheet
    Set ws = sourceWs
    
    Dim headerRow As Long
    Dim answer As String
    
    ' 1) Спросить строку шапки и удалить строки выше
    answer = InputBox("Введите номер строки, в которой находятся заголовки таблицы:" & vbCrLf & _
                      "(Все строки выше будут удалены)", "Строка с заголовками", "1")
    If Not IsNumeric(answer) Or Val(answer) < 1 Then
        MsgBox "Введено неверное значение. Макрос остановлен.", vbExclamation
        Exit Sub
    End If
    headerRow = CLng(answer)

    On Error Resume Next
    sourceWs.Copy After:=sourceWs
    If Err.Number <> 0 Then
        Dim copyError As String
        copyError = Err.Description
        Err.Clear
        On Error GoTo 0
        MsgBox "Не удалось создать копию исходного листа. Макрос остановлен." & vbCrLf & copyError, vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    Set ws = ActiveSheet
    ws.Name = BuildUniqueNormalizedSheetNameG(ws.Parent, sourceWs.Name)

    If headerRow > 1 Then
        ws.Rows("1:" & headerRow - 1).Delete Shift:=xlUp
        headerRow = 1
    End If
    
    ' Убрать слияния (мешают распознаванию строк подразделений)
    On Error Resume Next
    ws.UsedRange.UnMerge
    On Error GoTo 0
    
    Dim lastCol As Long, lastRow As Long
    lastCol = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).Column
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    If lastRow < headerRow + 1 Then
        MsgBox "Не найдено данных ниже шапки.", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    On Error GoTo Cleanup
    
    ' 2) Целевой порядок и варианты заголовков
    Dim targetOrder As Variant
    targetOrder = Array("Дата приема", "Подразделение", "ФИО", "Должность", "Дата рождения", "СНИЛС")
    
    Dim variants As Object
    Set variants = CreateObject("Scripting.Dictionary")
    variants.CompareMode = 1
    variants.Add "Дата приема", Array("дата приема", "дата принятия", "дата приема или перевода", "дата начала", "принят", "принятие", "date hire", "hire date", "date of hire", "принят/переведен")
    variants.Add "Подразделение", Array("подразделение", "название подразделения", "структурное подразделение", "отдел", "департамент", "unit", "division")
    variants.Add "ФИО", Array("фио", "сотрудник", "фамилия имя отчество", "ф.и.о.", "фамилия имя", "фамилия, имя, отчество", "full name", "employee")
    variants.Add "Должность", Array("должность", "должность (специальность, профессия), разряд, класс (категория) квалификации", "position", "job title", "title", "роль")
    variants.Add "Дата рождения", Array("дата рождения", "др", "рождение", "birthday", "birth date", "date of birth", "dob")
    variants.Add "СНИЛС", Array("снилс", "snils", "страховой номер", "пенсионное страхование")
    
    ' 3) Карта колонок по текущей шапке
    Dim mapCol As Object
    Set mapCol = CreateObject("Scripting.Dictionary")
    mapCol.CompareMode = 1
    
    Dim col As Long, key As Variant
    For col = 1 To lastCol
        Dim hdr As String
        hdr = Trim(CStr(ws.Cells(headerRow, col).Value))
        If Len(hdr) > 0 Then
            Dim normalized As String
            normalized = NormalizeHeaderG(hdr)
            For Each key In variants.Keys
                If IsHeaderMatchGG(normalized, variants(key)) Then
                    If Not mapCol.Exists(key) Then mapCol.Add key, col
                    Exit For
                End If
            Next key
        End If
    Next col
    
    ' 4) Столбец "Подразделение": создать, если нет
    Dim deptCol As Long
    If mapCol.Exists("Подразделение") Then
        deptCol = mapCol("Подразделение")
    Else
        ws.Cells(headerRow, lastCol + 1).EntireColumn.Insert
        ws.Cells(headerRow, lastCol + 1).Value = "Подразделение"
        deptCol = lastCol + 1
        lastCol = lastCol + 1
    End If
    
    ' Ключевые индексы (могут отсутствовать)
    Dim fioCol As Long, hireCol As Long, dobCol As Long, snilsCol As Long, titleCol As Long
    fioCol = GetColByHeaderG(ws, headerRow, "ФИО")
    hireCol = GetColByHeaderG(ws, headerRow, "Дата приема")
    dobCol = GetColByHeaderG(ws, headerRow, "Дата рождения")
    snilsCol = GetColByHeaderG(ws, headerRow, "СНИЛС")
    titleCol = GetColByHeaderG(ws, headerRow, "Должность")
    
    ' 5) Разбор блоков подразделений
    Dim currentDept As String: currentDept = ""
    Dim rowsToDelete As Collection: Set rowsToDelete = New Collection
    
    Dim r As Long
    For r = headerRow + 1 To lastRow
        Dim nonEmpty As Long: nonEmpty = 0
        Dim firstText As String: firstText = ""
        Dim c As Long
        For c = 1 To lastCol
            If c <> deptCol Then
                Dim cellText As String
                cellText = Trim(CStr(ws.Cells(r, c).Value))
                If Len(cellText) > 0 Then
                    nonEmpty = nonEmpty + 1
                    If Len(firstText) = 0 Then firstText = cellText
                End If
            End If
        Next c
        
        Dim looksLikeData As Boolean: looksLikeData = False
        If fioCol > 0 Then If Len(Trim(CStr(ws.Cells(r, fioCol).Value))) > 0 Then looksLikeData = True
        If Not looksLikeData And hireCol > 0 Then If Len(Trim(CStr(ws.Cells(r, hireCol).Value))) > 0 Then looksLikeData = True
        If Not looksLikeData And dobCol > 0 Then If Len(Trim(CStr(ws.Cells(r, dobCol).Value))) > 0 Then looksLikeData = True
        If Not looksLikeData And snilsCol > 0 Then If Len(Trim(CStr(ws.Cells(r, snilsCol).Value))) > 0 Then looksLikeData = True
        If Not looksLikeData And titleCol > 0 Then If Len(Trim(CStr(ws.Cells(r, titleCol).Value))) > 0 Then looksLikeData = True
        
        Dim isDeptHeader As Boolean: isDeptHeader = False
        If nonEmpty <= 2 And Len(firstText) > 0 And Not looksLikeData Then
            Dim probe As String: probe = LCase$(firstText)
            Dim tmpDate As Date
            If Not IsDate(firstText) And Not TryParseDMYG(Replace(Replace(firstText, "/", "."), "-", "."), tmpDate) Then
                If InStr(probe, "отдел") > 0 Or InStr(probe, "департ") > 0 Or InStr(probe, "служб") > 0 Or _
                   InStr(probe, "цех") > 0 Or InStr(probe, "участок") > 0 Or InStr(probe, "управлен") > 0 Then
                    isDeptHeader = True
                Else
                    isDeptHeader = True
                End If
            End If
        End If
        
        If isDeptHeader Then
            currentDept = firstText
            rowsToDelete.Add r
        Else
            If Len(currentDept) > 0 Then
                If Len(Trim(CStr(ws.Cells(r, deptCol).Value))) = 0 Then
                    ws.Cells(r, deptCol).Value = currentDept
                End If
            End If
        End If
    Next r
    
    ' Удалить строки-шапки подразделений снизу вверх
    Dim idx As Long
    For idx = rowsToDelete.Count To 1 Step -1
        r = CLng(rowsToDelete(idx))
        If r >= headerRow + 1 And r <= ws.Rows.Count Then
            ws.Rows(r).Delete
        End If
    Next idx
    
    ' 6) Оставить только известные, переставить, переименовать
    lastCol = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).Column
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    Set mapCol = RebuildMapG(ws, headerRow, variants)
    
    Dim toKeep As Object: Set toKeep = CreateObject("Scripting.Dictionary")
    For Each key In mapCol.Keys
        toKeep(CStr(mapCol(key))) = True
    Next key
    For col = lastCol To 1 Step -1
        If Not toKeep.Exists(CStr(col)) Then ws.Columns(col).Delete
    Next col
    
    lastCol = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).Column
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    Set mapCol = RebuildMapG(ws, headerRow, variants)
    
    Dim i As Long, newPos As Long: newPos = 1
    For i = LBound(targetOrder) To UBound(targetOrder)
        If mapCol.Exists(targetOrder(i)) Then
            Dim currentCol As Long: currentCol = mapCol(targetOrder(i))
            If currentCol <> newPos Then
                ws.Columns(currentCol).Cut
                ws.Columns(newPos).Insert Shift:=xlToRight
                Set mapCol = RebuildMapG(ws, headerRow, variants)
            End If
        Else
            ws.Columns(newPos).Insert Shift:=xlToRight
            ws.Cells(headerRow, newPos).Value = targetOrder(i)
            Set mapCol = RebuildMapG(ws, headerRow, variants)
        End If
        ws.Cells(headerRow, newPos).Value = targetOrder(i)
        newPos = newPos + 1
    Next i

    lastCol = UBound(targetOrder) - LBound(targetOrder) + 1
    
    ' 7) Даты, ФИО, СНИЛС
    hireCol = GetColByHeaderG(ws, headerRow, "Дата приема")
    dobCol = GetColByHeaderG(ws, headerRow, "Дата рождения")
    fioCol = GetColByHeaderG(ws, headerRow, "ФИО")
    snilsCol = GetColByHeaderG(ws, headerRow, "СНИЛС")
    
    If hireCol > 0 Then
        CoerceColumnToDateG ws, hireCol, headerRow + 1, lastRow
        ws.Columns(hireCol).NumberFormat = "dd.mm.yyyy"
    End If
    If dobCol > 0 Then
        CoerceColumnToDateG ws, dobCol, headerRow + 1, lastRow
        ws.Columns(dobCol).NumberFormat = "dd.mm.yyyy"
    End If
    If fioCol > 0 Then TrimTextColumnG ws, fioCol, headerRow + 1, lastRow
    If snilsCol > 0 Then NormalizeSnilsColumnG ws, snilsCol, headerRow + 1, lastRow
    
    ' 8) Фильтр, форматирование, сортировка
    lastCol = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).Column
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim tableRange As Range
    Set tableRange = ws.Range(ws.Cells(headerRow, 1), ws.Cells(lastRow, lastCol))
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    On Error Resume Next
    If Not ws.AutoFilter Is Nothing Then ws.AutoFilter.ShowAllData
    On Error GoTo 0
    
    tableRange.AutoFilter
    
    With tableRange.Font
        .Name = "Arial"
        .Size = 8
        .Bold = False
    End With
    
    With tableRange.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With tableRange.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With tableRange.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    ws.Columns.AutoFit
    ws.Rows(headerRow).RowHeight = 21
    If lastRow > headerRow Then ws.Range(ws.Rows(headerRow + 1), ws.Rows(lastRow)).RowHeight = 12
    
    If hireCol > 0 And lastRow > headerRow + 1 Then
        Dim sortRange As Range
        Set sortRange = tableRange
        sortRange.Sort _
            Key1:=ws.Cells(headerRow, hireCol), _
            Order1:=xlDescending, _
            Header:=xlYes, _
            MatchCase:=False, _
            Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        If Not ws.AutoFilterMode Then sortRange.AutoFilter
    End If
    
    MsgBox "Готово! Нормализованный лист: """ & ws.Name & """." & vbCrLf & _
           "Исходный лист """ & sourceWs.Name & """ не изменён.", vbInformation

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function BuildUniqueNormalizedSheetNameG(ByVal wb As Workbook, ByVal sourceName As String) As String
    Dim stem As String
    stem = Left$(sourceName & "_СОТик", 27)

    Dim candidate As String
    candidate = stem

    Dim suffix As Long
    suffix = 2
    Do While SheetNameExistsG(wb, candidate)
        candidate = Left$(stem, 30 - Len(CStr(suffix))) & "_" & CStr(suffix)
        suffix = suffix + 1
    Loop

    BuildUniqueNormalizedSheetNameG = candidate
End Function

Private Function SheetNameExistsG(ByVal wb As Workbook, ByVal sheetName As String) As Boolean
    Dim probe As Worksheet
    On Error Resume Next
    Set probe = wb.Worksheets(sheetName)
    SheetNameExistsG = Not probe Is Nothing
    Set probe = Nothing
    On Error GoTo 0
End Function

' ===== ВСПОМОГАТЕЛЬНЫЕ (варианты с суффиксом G, чтобы не конфликтовать) =====

Private Function NormalizeHeaderG(ByVal s As String) As String
    s = LCase$(Trim$(s))
    s = Replace(s, vbCr, " ")
    s = Replace(s, vbLf, " ")
    s = Application.WorksheetFunction.Trim(s)
    NormalizeHeaderG = s
End Function

Private Function IsHeaderMatchGG(ByVal norm As String, ByVal arr) As Boolean
    Dim v As Variant
    For Each v In arr
        Dim probe As String
        probe = LCase$(Trim$(CStr(v)))
        If norm = probe Then
            IsHeaderMatchGG = True
            Exit Function
        End If
        If InStr(1, norm, probe, vbTextCompare) > 0 Then
            IsHeaderMatchGG = True
            Exit Function
        End If
    Next v
    IsHeaderMatchGG = False
End Function

Private Function RebuildMapG(ws As Worksheet, headerRow As Long, variants As Object) As Object
    Dim mapCol As Object: Set mapCol = CreateObject("Scripting.Dictionary")
    mapCol.CompareMode = 1
    Dim lastC As Long: lastC = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).Column
    Dim c As Long, h As String, key As Variant
    For c = 1 To lastC
        h = NormalizeHeaderG(CStr(ws.Cells(headerRow, c).Value))
        For Each key In variants.Keys
            If IsHeaderMatchGG(h, variants(key)) Then
                If Not mapCol.Exists(key) Then mapCol.Add key, c
                Exit For
            End If
        Next key
    Next c
    Set RebuildMapG = mapCol
End Function

Private Function GetColByHeaderG(ws As Worksheet, headerRow As Long, headerName As String) As Long
    Dim lastC As Long: lastC = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).Column
    Dim c As Long
    For c = 1 To lastC
        If LCase$(Trim$(CStr(ws.Cells(headerRow, c).Value))) = LCase$(headerName) Then
            GetColByHeaderG = c
            Exit Function
        End If
    Next c
    GetColByHeaderG = 0
End Function

' ===== ДАТЫ (G) =====

Private Sub CoerceColumnToDateG(ws As Worksheet, ByVal colIdx As Long, ByVal rowStart As Long, ByVal rowEnd As Long)
    If colIdx <= 0 Then Exit Sub
    
    Dim r As Long
    Dim dateRange As Range
    Set dateRange = ws.Range(ws.Cells(rowStart, colIdx), ws.Cells(rowEnd, colIdx))
    
    dateRange.ClearFormats
    
    For r = rowStart To rowEnd
        Dim v As Variant
        v = ws.Cells(r, colIdx).Value
        
        If IsEmpty(v) Or v = "" Then
            ' пропуск
        Else
            If IsDate(v) Then
                ws.Cells(r, colIdx).Value = CDate(v)
            Else
                Dim s As String
                s = Trim$(CStr(v))
                If Len(s) > 0 Then
                    s = Replace(s, "/", ".")
                    s = Replace(s, "-", ".")
                    s = Replace(s, " ", ".")
                    s = Replace(s, "..", ".")
                    
                    Dim cleaned As String
                    cleaned = KeepDigitsAndDotsG(s)
                    
                    Dim d As Date, d2 As Date
                    If TryParseDMYG(cleaned, d) Then
                        ws.Cells(r, colIdx).Value = d
                    Else
                        If TryParseWithMonthTextG(CStr(v), d2) Then
                            ws.Cells(r, colIdx).Value = d2
                        Else
                            If IsNumeric(v) Then
                                Dim sn As Double
                                sn = CDbl(v)
                                If sn > 1 And sn < 100000 Then
                                    ws.Cells(r, colIdx).Value = sn
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next r
    
    dateRange.Copy
    dateRange.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    dateRange.Calculate
    dateRange.NumberFormat = "dd.mm.yyyy"
    
    For r = rowStart To rowEnd
        If IsNumeric(ws.Cells(r, colIdx).Value) Then
            If ws.Cells(r, colIdx).Value <> 0 Then
                ws.Cells(r, colIdx).Value = ws.Cells(r, colIdx).Value
            End If
        End If
    Next r
End Sub

Private Function KeepDigitsAndDotsG(ByVal s As String) As String
    Dim i As Long, ch As String, res As String
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        If (ch >= "0" And ch <= "9") Or ch = "." Then
            res = res & ch
        End If
    Next i
    Do While InStr(res, "..") > 0
        res = Replace(res, "..", ".")
    Loop
    KeepDigitsAndDotsG = res
End Function

Private Function TryParseDMYG(ByVal s As String, ByRef outDate As Date) As Boolean
    On Error GoTo fail
    Dim parts() As String
    parts = Split(s, ".")
    If UBound(parts) < 2 Then GoTo fail
    
    Dim dd As Long, mm As Long, yy As Long
    dd = CLng(Val(parts(0)))
    mm = CLng(Val(parts(1)))
    yy = CLng(Val(parts(2)))
    
    If yy < 100 Then
        If yy >= 30 Then
            yy = 1900 + yy
        Else
            yy = 2000 + yy
        End If
    End If
    
    If dd >= 1 And dd <= 31 And mm >= 1 And mm <= 12 Then
        outDate = DateSerial(yy, mm, dd)
        TryParseDMYG = True
        Exit Function
    End If
fail:
    TryParseDMYG = False
End Function

Private Function TryParseWithMonthTextG(ByVal s As String, ByRef outDate As Date) As Boolean
    On Error GoTo fail
    Dim txt As String
    txt = LCase$(Trim$(s))
    txt = Replace(txt, ",", " ")
    txt = Replace(txt, "  ", " ")
    txt = Application.WorksheetFunction.Trim(txt)
    
    Dim dd As Long, yy As Long, mm As Long
    dd = ExtractFirstNumberG(txt)
    yy = ExtractLastNumberG(txt)
    
    If yy < 100 And yy > 0 Then
        If yy >= 30 Then
            yy = 1900 + yy
        Else
            yy = 2000 + yy
        End If
    End If
    
    mm = MonthFromRusTextG(txt)
    If dd >= 1 And dd <= 31 And mm >= 1 And mm <= 12 Then
        outDate = DateSerial(yy, mm, dd)
        TryParseWithMonthTextG = True
        Exit Function
    End If
fail:
    TryParseWithMonthTextG = False
End Function

Private Function MonthFromRusTextG(ByVal s As String) As Integer
    If InStr(s, "янв") > 0 Then MonthFromRusTextG = 1: Exit Function
    If InStr(s, "фев") > 0 Then MonthFromRusTextG = 2: Exit Function
    If InStr(s, "мар") > 0 Then MonthFromRusTextG = 3: Exit Function
    If InStr(s, "апр") > 0 Then MonthFromRusTextG = 4: Exit Function
    If InStr(s, "мая") > 0 Or InStr(s, "май") > 0 Then MonthFromRusTextG = 5: Exit Function
    If InStr(s, "июн") > 0 Then MonthFromRusTextG = 6: Exit Function
    If InStr(s, "июл") > 0 Then MonthFromRusTextG = 7: Exit Function
    If InStr(s, "авг") > 0 Then MonthFromRusTextG = 8: Exit Function
    If InStr(s, "сен") > 0 Then MonthFromRusTextG = 9: Exit Function
    If InStr(s, "окт") > 0 Then MonthFromRusTextG = 10: Exit Function
    If InStr(s, "ноя") > 0 Then MonthFromRusTextG = 11: Exit Function
    If InStr(s, "дек") > 0 Then MonthFromRusTextG = 12
End Function

Private Function ExtractFirstNumberG(ByVal s As String) As Long
    Dim i As Long, ch As String, buf As String
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        If ch >= "0" And ch <= "9" Then
            buf = buf & ch
        Else
            If Len(buf) > 0 Then
                Exit For
            End If
        End If
    Next i
    If Len(buf) > 0 Then
        ExtractFirstNumberG = CLng(buf)
    Else
        ExtractFirstNumberG = 0
    End If
End Function

Private Function ExtractLastNumberG(ByVal s As String) As Long
    Dim i As Long, ch As String, buf As String
    For i = Len(s) To 1 Step -1
        ch = Mid$(s, i, 1)
        If ch >= "0" And ch <= "9" Then
            buf = ch & buf
        Else
            If Len(buf) > 0 Then
                Exit For
            End If
        End If
    Next i
    If Len(buf) > 0 Then
        ExtractLastNumberG = CLng(buf)
    Else
        ExtractLastNumberG = 0
    End If
End Function

Private Sub TrimTextColumnG(ws As Worksheet, ByVal colIdx As Long, ByVal rowStart As Long, ByVal rowEnd As Long)
    If colIdx <= 0 Then Exit Sub
    Dim r As Long, s As String
    For r = rowStart To rowEnd
        s = CStr(ws.Cells(r, colIdx).Value)
        s = Application.WorksheetFunction.Trim(s)
        ws.Cells(r, colIdx).Value = s
    Next r
End Sub

Private Sub NormalizeSnilsColumnG(ws As Worksheet, ByVal colIdx As Long, ByVal rowStart As Long, ByVal rowEnd As Long)
    If colIdx <= 0 Then Exit Sub
    Dim r As Long, digits As String
    For r = rowStart To rowEnd
        digits = KeepDigitsOnlyG(CStr(ws.Cells(r, colIdx).Value))
        If Len(digits) = 11 Then
            ws.Cells(r, colIdx).Value = Mid$(digits, 1, 3) & "-" & Mid$(digits, 4, 3) & "-" & Mid$(digits, 7, 3) & " " & Mid$(digits, 10, 2)
        ElseIf Len(digits) > 0 Then
            ws.Cells(r, colIdx).Value = digits
        End If
    Next r
End Sub

Private Function KeepDigitsOnlyG(ByVal s As String) As String
    Dim i As Long, ch As String, res As String
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        If ch >= "0" And ch <= "9" Then
            res = res & ch
        End If
    Next i
    KeepDigitsOnlyG = res
End Function