Sub VitaminSort()
Dim arr(), sArr(), a&, b%, emArr(), c%, d%, i%
With ActiveSheet
  arr = .Range(.Cells(2, 6), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Value
  For a = 1 To UBound(arr)
    ReDim sArr(1 To UBound(arr, 2)): emArr = sArr
    c = 1: d = 1
    For b = 1 To UBound(arr, 2)
      If Len(arr(a, b)) > 1 Then
        sArr(c) = arr(a, b): c = c + 1
      Else: emArr(d) = arr(a, b): d = d + 1
      End If
    Next
    If c > 1 Then
      arr(a, 1) = sArr(1)
      If c > 2 Then
        For b = 2 To c - 1
          i = b
          Do While arr(a, i - 1) > sArr(i)
            arr(a, i) = arr(a, i - 1): i = i - 1
            If i = 1 Then Exit Do
          Loop
          arr(a, i) = sArr(i)
        Next
      End If
      If d > 1 Then
        i = 1
        For b = c To UBound(sArr): arr(a, b) = emArr(i): i = i + 1: Next
      End If
    End If
  Next
  .[F2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub

Sub мяу()
    Dim r As Range, i&
    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets(1)
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            Set r = .Range("F" & i).Resize(, 7)
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=r(1) _
                              , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                                xlSortNormal
                .SetRange r
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlLeftToRight
                .SortMethod = xlPinYin
                .Apply
            End With
        Next
    End With
    Application.ScreenUpdating = True

End Sub