Option Explicit
Sub jjj() ' _
http://planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=70337&TITLE_SEO=70337-avtomaticheskoe-zapolnenie-tablitsy&MID=589546#message589546
Dim Rng As Range, ars As Range, dict As Object, objRegExp As Object, i_fRow%, i_lRow%, i%, arr, tmp_str$, path_str$, dc
    Set dict = CreateObject("Scripting.Dictionary")
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Pattern = "[^\d\wА-ЯЁа-яё]"
    path_str = ActiveWorkbook.Path & "\"
    With ActiveWorkbook.ActiveSheet
        If .FilterMode Then .ShowAllData
        i_fRow = 3
        i_lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(i_fRow, 1), .Cells(i_lRow, 1))
    End With 'ActiveSheet
    For i = 1 To UBound(arr)
        dict(arr(i, 1)) = arr(i, 1)
    Next i
    For Each dc In dict
        tmp_str = dc
        While objRegExp.Test(tmp_str)
            tmp_str = objRegExp.Replace(tmp_str, "_")
        Wend
        ActiveSheet.Copy
        With ActiveWorkbook.ActiveSheet
                .AutoFilter.Sort.SortFields.Clear
                .AutoFilter.Sort.SortFields.Add Key:=.Range(.Cells(i_fRow - 1, 1), .Cells(i_lRow, 1)), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            .Range(.Cells(i_fRow - 1, 1), .Cells(i_lRow, 1)).AutoFilter Field:=1, Criteria1:= _
                "<>" & dc, Operator:=xlAnd
            On Error Resume Next
            Set Rng = .Range(.Cells(i_fRow, 1), .Cells(i_lRow, 1)).SpecialCells(xlCellTypeVisible).EntireRow
            On Error GoTo 0
            If Not Rng Is Nothing Then Rng.Delete xlShiftUp
            If .FilterMode Then .ShowAllData
        End With 'ActiveSheet
        ActiveWorkbook.Close True, path_str & tmp_str
    Next dc
End Sub