Hey Devendra, This code made me insane :*0,Let me tell you why ?? 1) Numerous of Keywords Integers,Y,Years,SR Doesn't understood the meaning what they are denoting Except years. 2) Took(Almost 2.5 hour).
Sorting is easy when all are numbers but difficult when Text values !! the previous code you were using was doing nothing like sorting they are just comparing on the basis of Text values That code was comparing Text values like 10-12 years,11-15 years in which 10,10years,15 years in which 1 comes first and they are providing you the same. I Tried my best to solve your problem but this code will gives you different result if your Data keywords will change. I followed this way for Sorting if I go as per sorting rule of numbers !! Sorting -Way ->>> Interger--->then----> Y values----> years values --->Rest of values(which are not integer not years,not Y God knows What they are) Here's the code !!! Note this code very specific for keywords you have provided to me Y,Years,Integers,SR,Normal Sub SOA() On Error Resume Next Application.ScreenUpdating = False Dim ws As Worksheet Dim counter As Long: counter = 1 Dim Nrows As Long Set ws = ActiveWorkbook.Sheets("Sheet3") Set ws1 = ActiveWorkbook.Sheets("Data") Nrows = ws1.Cells(Rows.Count, 2).End(xlUp).Row 'Get no of rows For Rownum = 2 To Nrows ws.Cells.ClearContents 'Clear the rough sheet Set temp = Nothing 'A variable to hold the result Dim varout1() As Variant Dim varout() As Variant var1 = Split(ws1.Cells(Rownum, "B"), ",") For i = LBound(var1) To UBound(var1) If IsNumeric(var1(i)) Then ReDim Preserve varout1(1 To counter) varout1(counter) = var1(i) counter = counter + 1 End If Next Sheets("sheet3").Range("a1").Resize(UBound(varout1), 1) = Application.Transpose(varout1) '-------------------------------------------------------------------- counter = 1 Debug.Print ws1.Cells(Rownum, "B") var1 = Split(ws1.Cells(Rownum, "B"), ",") For i = LBound(var1) To UBound(var1) If Right(var1(i), 1) = "Y" Then ReDim Preserve varout1(1 To counter) varout1(counter) = var1(i) counter = counter + 1 End If Next Sheets("sheet3").Range("c1").Resize(UBound(varout1), 1) = Application.Transpose(varout1) Sheets("sheet3").Range("D1").Resize(UBound(varout1), 1) = Application.Transpose(varout1) '------------------------------------------------------------- counter = 1 var1 = Split(ws1.Cells(Rownum, "B"), ",") For i = LBound(var1) To UBound(var1) If var1(i) Like "*Years*" Then ReDim Preserve varout1(1 To counter) varout1(counter) = var1(i) counter = counter + 1 End If Next Sheets("sheet3").Range("f1").Resize(UBound(varout1), 1) = Application.Transpose(varout1) Sheets("sheet3").Range("G1").Resize(UBound(varout1), 1) = Application.Transpose(varout1) '----------------------------------------------------------------------------------------------------- counter = 1 var1 = Split(ws1.Cells(Rownum, "B"), ",") For i = LBound(var1) To UBound(var1) If Not var1(i) Like "*Years*" Then If Not Right(var1(i), 1) = "Y" Then If Not IsNumeric(var1(i)) = True Then ReDim Preserve varout1(1 To counter) varout1(counter) = var1(i) counter = counter + 1 End If End If End If Next Sheets("sheet3").Range("K1").Resize(UBound(varout1), 1) = Application.Transpose(varout1) Sheets("sheet3").Range("L1").Resize(UBound(varout1), 1) = Application.Transpose(varout1) ActiveWorkbook.Worksheets("Sheet3").sort.SortFields.Clear lr = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row ActiveWorkbook.Worksheets("Sheet3").sort.SortFields.Add Key:=Sheets("Sheet3").Range("A1"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet3").sort .SetRange ws.Range("A1:B" & lr) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With lr = Sheets("Sheet3").Cells(Rows.Count, 3).End(xlUp).Row Sheets("Sheet3").Columns("C:C").Replace What:="-*", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Sheets("Sheet3").Columns("C:C").Replace What:="Y", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False '--------------------------Sorting column second ActiveWorkbook.Worksheets("Sheet3").sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet3").sort.SortFields.Add Key:=Sheets("Sheet3").Range("C1"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet3").sort .SetRange Range("C1:D" & lr) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With '------------------------------------------------------------------------------- lr = Sheets("Sheet3").Cells(Rows.Count, 6).End(xlUp).Row Sheets("Sheet3").Columns("F:F").Replace What:="-*", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Sheets("Sheet3").Columns("F:F").Replace What:="Years", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False ActiveWorkbook.Worksheets("Sheet3").sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet3").sort.SortFields.Add Key:=Sheets("Sheet3").Range("f1"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet3").sort .SetRange Range("f1:g" & lr) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'Dim varout() As Variant counter = 1 l1 = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row l2 = Sheets("Sheet3").Cells(Rows.Count, 4).End(xlUp).Row l3 = Sheets("Sheet3").Cells(Rows.Count, 7).End(xlUp).Row l4 = Sheets("Sheet3").Cells(Rows.Count, 11).End(xlUp).Row For i = 1 To l1 ReDim Preserve varout(1 To counter) varout(i) = ws.Cells(i, 1).Value counter = counter + 1 Next ' MsgBox Join(varout, ",") For j = 1 To l2 ReDim Preserve varout(1 To counter + 1) varout(counter) = ws.Cells(j, 4).Value counter = counter + 1 Next 'MsgBox Join(varout, ",") For k = 1 To l3 ReDim Preserve varout(1 To counter + 1) varout(counter) = ws.Cells(k, 7).Value counter = counter + 1 Next For L = 1 To l4 ReDim Preserve varout(1 To counter + 1) varout(counter) = ws.Cells(L, 11).Value counter = counter + 1 Next temp = Join(varout, ",") ws1.Cells(Rownum, "C").Value = temp Next 'ws.Cells.ClearContents End Sub Regards, Mandeep baluja https://www.facebook.com/groups/825221420889809/ -- Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s =TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @ https://www.facebook.com/discussexcel FORUM RULES 1) Use concise, accurate thread titles. Poor thread titles, like Please Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get quick attention or may not be answered. 2) Don't post a question in the thread of another member. 3) Don't post questions regarding breaking or bypassing any security measure. 4) Acknowledge the responses you receive, good or bad. 5) Jobs posting is not allowed. 6) Sharing copyrighted material and their links is not allowed. NOTE : Don't ever post confidential data in a workbook. Forum owners and members are not responsible for any loss. --- You received this message because you are subscribed to the Google Groups "MS EXCEL AND VBA MACROS" group. To unsubscribe from this group and stop receiving emails from it, send an email to excel-macros+unsubscr...@googlegroups.com. To post to this group, send email to excel-macros@googlegroups.com. Visit this group at https://groups.google.com/group/excel-macros. For more options, visit https://groups.google.com/d/optout.
Sorting.xlsm
Description: application/vnd.ms-excel.sheet.macroenabled.12