Public Sub SplitData()
On Error Resume Next
Application.ScreenUpdating = False
'***************************
Flt = "FALSE"
On Error Resume Next
Flt = Selection.AutoFilter
If Flt = "TRUE" Then Selection.AutoFilter
'**************************
Orig = ActiveSheet.Name
Last_row = Application.Cells.SpecialCells(xlCellTypeLastCell).Row
col = InputBox("äçìå÷ä úáåññ òì òîåãä (A-Z):", "çìå÷ú âéìéåï ìîëåúáéí", "A")
fRow = Val(InputBox("ùåøú ðúåðéí øàùåðä (àçøé ëåúøåú):", "çìå÷ú âéìéåï ìîëåúáéí", "2"))
If Len(col) <> 1 Or col < "A" Or col > "Z" Then
x = MsgBox("ðáçøä òîåãä ìà çå÷éú", vbCritical + vbOKOnly, "áçéøä ìà çå÷éú")
Exit Sub
End If
'*********************
'*** Get distinct vals
'*********************
Dim tmp As String
Dim arr() As String
Erase arr
For Each Cell In Range(col & fRow & ":" & col & Last_row)
If (Cell <> "") And (InStr(tmp, Cell) = 0) Then
tmp = tmp & Cell & "|"
End If
Next Cell
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
NoOfDist = UBound(arr)
If NoOfDist > 128 Then
x = MsgBox("áòîåãä ùðáçøä ÷ééîéí éåúø î - 28 òøëéí ùåðéí", vbCritical + vbOKOnly, "áçéøä ìà çå÷éú")
Exit Sub
End If
'*********************
For dep = 0 To NoOfDist
Sheets(Orig).Select
Sheets(Orig).Copy Before:=Sheets(1)
ActiveSheet.Name = arr(dep)
If fRow = 1 Then
mv = 0
Else
mv = 1
End If
Range(col & fRow - mv & ":" & col & Last_row).Select
CrFld = Asc(col) - 64
Selection.AutoFilter Field:=CrFld, Criteria1:="<>" & arr(dep), Operator:=xlAnd
' Selection.AutoFilter Field:=1, Criteria1:="<>" & arr(dep), Operator:=xlAnd
Rows(fRow & ":" & Last_row).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=CrFld
' Selection.AutoFilter Field:=1
Range("A1").Select
Next dep
Sheets(Orig).Select
Application.ScreenUpdating = True
End Sub
