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