Sub Sorting()
Dim Cell2 As String
Cell2 = ActiveCell.Address
Column2 = ActiveCell.Offset(0, 1).EntireColumn.AddressLocal
Range(Column2).Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cell2).Select
Do Until ActiveCell.Text = ""
Dim Cell
Cell = ActiveCell
If Cell = UCase(Cell) Then
ActiveCell.Offset(0, 1).Value = 1
Else
If Selection.Font.Bold = True Then
ActiveCell.Offset(0, 1).Value = 2
Else
If Selection.Font.Italic = True Then
ActiveCell.Offset(0, 1).Value = 3
End If
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=ActiveCell.Columns.Offset(0, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(ActiveCell, ActiveCell.Offset(0, 1)).EntireColumn
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range(Column2).Select
Selection.Delete Shift:=xlToLeft
Range(Cell2).Select
End Sub
Sub Sorting()
Dim Cell2 As String
Cell2 = ActiveCell.Address
Column2 = ActiveCell.Offset(0, 1).EntireColumn.AddressLocal
Range(Column2).Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cell2).Select
Do Until ActiveCell.Text = ""
Dim Cell
Cell = ActiveCell
If Cell = UCase(Cell) Then
ActiveCell.Offset(0, 1).Value = 1
Else
If Selection.Font.Bold = True Then
ActiveCell.Offset(0, 1).Value = 2
Else
If Selection.Font.Italic = True Then
ActiveCell.Offset(0, 1).Value = 3
End If
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=ActiveCell.Columns.Offset(0, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=ActiveCell.Columns _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(ActiveCell, ActiveCell.Offset(0, 1)).EntireColumn
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range(Column2).Select
Selection.Delete Shift:=xlToLeft
Range(Cell2).Select
End Sub