Result type2 is here:
Sub SortRangeData2()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rng1 As Range, rng2 As Range, rng As Range, data As Range
Dim arr As Variant, arr2 As String, txt As String
Dim i As Long, lr As Long
Set sh1 = ActiveSheet
On Error Resume Next
Set data = Application.Selection
Set data = Application.InputBox("Selet Data", Type:=8)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Worksheets.Add after:=Sheets(Sheets.Count)
Set sh2 = ActiveSheet
For Each rng1 In data
arr = VBA.Split(rng1, ",")
For i = 0 To UBound(arr)
sh2.Cells((i + 1), 1).Value = arr(i)
sh2.Cells((i + 1), 2).FormulaR1C1 = "=LEN(RC[-1])"
Next i
lr = sh2.Range("A" & Rows.Count).End(xlUp).Row
sh2.Range("A1:B" & lr).Select
With Selection
sh2.Sort.SortFields.Clear
sh2.Sort.SortFields.Add Key:=Range("B1"), Order:=xlAscending
sh2.Sort.SortFields.Add Key:=Range("A1"), Order:=xlAscending
End With
With sh2.Sort
.SetRange Selection
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
sh2.Range("D1").Select
sh2.Range("A1:A" & lr).Select
For Each rng In Selection
txt = rng & ","
arr2 = arr2 & txt
Next rng
sh2.Range("A1:B" & lr).Clear
rng1.Offset(0, 2).Value = arr2
arr2 = ""
Next rng1
sh2.Delete
If ActiveSheet.Name <> sh1.Name Then sh1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
*PJ *
*MIS Analyst*
*Greater Kailash-1, New Delhi.*
*Instagram* *pj_sharma_*
*Tweeter*
*dude_sharma_pj**Facebook** www.facebook.com/dude.pj
<http://www.facebook.com/dude.pj>*
*We meet for a reason, either you're a blessing or a lesson...*
On Fri, Jan 15, 2016 at 6:02 PM, Mandeep Baluja <rockerna...@gmail.com>
wrote:
> 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.
>
--
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.
Comma Separated (solved 2).xlsm
Description: application/vnd.ms-excel.sheet.macroenabled.12
