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
