Query: I want to sort sheet in Ascending or Descending order, please not it has Alpha numeric name so I want sort it in serial order e.g. A1,A2,A3,A11,A12 and not A1,A11,A12,A2,A3
Solution: when comes to sorting 1, 11 & 111 are considered as same picture character resulting into sorting sheet incorrectly, try below code to get desired results:
Solution: when comes to sorting 1, 11 & 111 are considered as same picture character resulting into sorting sheet incorrectly, try below code to get desired results:
Sub Sort_Active_Book_AlphaNum()
Dim i As Integer
Dim j As Integer
Dim a As Integer, b As Integer, Sn1 As String, Sn2 As String
Dim iAnswer As VbMsgBoxResult
Dim c As String
'
' Prompt the user as which direction they wish to
' sort the worksheets.
'
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
& "Clicking No will sort in Descending Order", _
vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1 'Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
If iAnswer = vbYes Then
Sn1 = "": Sn2 = ""
For a = 1 To Len(Sheets(j).Name)
If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then
Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)
End If
Next a
For b = 1 To Len(Sheets(j + 1).Name)
If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then
Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)
End If
Next b
If a <> 0 Then
If Val(Sn1) > Val(Sn2) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
Else
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
'
' If the answer is No, then sort in descending order.
'
ElseIf iAnswer = vbNo Then
Sn1 = "": Sn2 = ""
For a = 1 To Len(Sheets(j).Name)
If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then
Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)
End If
Next a
For b = 1 To Len(Sheets(j + 1).Name)
If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then
Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)
End If
Next b
If a <> 0 Then
If Val(Sn1) < Val(Sn2) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
Else
If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
End If
Next j
Next i
End Sub
Cheers!!
No comments:
Post a Comment