View Full Version : [SOLVED:] Help with a difficult sort
Obfuscated
10-07-2016, 05:06 AM
I need to correctly sort 6 columns of data. Example data:
W18X76 A9 55 2 X EA
W18X100 A9 55 2 X EA
W18X320 A8 45 1 A EX
I need to sort by the first column, second column, third column (hierarchy). The remaining columns just need to follow the route.
My trouble is that when the first column is sorted, it will be:
W18X100
W18X320
W18X76
It needs to be sorted on the entire number, not the first digit. Correct return should be:
W18X76 ...
W18X100 ...
W18X320 ...
The first entry will always have a letter (or 2) to start that will be "W", or "HP", then a 2 or 3 digit number.
Sorting by the number after the "X" is the key sort needed.
I have no idea how to accomplish this.
1)insert column and enter this formula
2)sort
3)delete column above
=SUBSTITUTE(SUBSTITUTE(A1,"W",""),"HP","")*1
Obfuscated
10-07-2016, 05:59 AM
I had to edit the entry to include the "18X" after the "W". So this answer will not work. Sorry, I had abbreviated my initial examples.
Paul_Hossler
10-07-2016, 06:19 AM
This uses a temporary column to hold the prefix while the number portion is sorted.
It joins the prefix back to the number, and then deletes the temp column
Assumes there are headers and that the data starts in A1
Option Explicit
Sub Demo()
Dim rData As Range, rDataHeaders As Range, rNumber As Range
Dim iX As Long
Dim sTemp As String
Application.ScreenUpdating = False
ActiveSheet.Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").Value = "temp"
Set rDataHeaders = ActiveSheet.Cells(1, 1).CurrentRegion
With rDataHeaders
Set rData = .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
End With
For Each rNumber In rData.Columns(1).Cells
With rNumber
sTemp = .Value
iX = InStr(sTemp, "X")
.Value = Right(sTemp, Len(.Value) - iX)
.Offset(0, 1).Value = Left(sTemp, iX)
End With
Next
With Worksheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=rData.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rDataHeaders
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For Each rNumber In rData.Columns(1).Cells
With rNumber
.Value = .Offset(0, 1).Value & .Value
End With
Next
Columns("B:B").Delete Shift:=xlToLeft
Application.ScreenUpdating = True
End Sub
=MID(A1,FIND("X",A1)+1,3)
Obfuscated
10-07-2016, 07:10 AM
I have posted the WB so you can see the code already written.
Thanks guys for the help.
Paul_Hossler
10-07-2016, 10:57 AM
I inserted the macro from post #4 and made some changes
Two lines are marked testing since I just wanted to see the sort part
JumpHere: '<<<<<<<<<<<<<<<<<<<<<<<<<< testing
Dim rData As Range, rDataHeaders As Range, rNumber As Range
Dim iX As Long
Dim sTemp As String
Application.ScreenUpdating = False
ws.Range("B3", Range("B3").End(xlDown)).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B3").Value = "temp"
Set rDataHeaders = ActiveSheet.Cells(1, 1).CurrentRegion
With rDataHeaders
Set rDataHeaders = .Cells(3, 1).Resize(.Rows.Count - 2, .Columns.Count)
End With
With rDataHeaders
Set rData = .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
End With
For Each rNumber In rData.Columns(1).Cells
With rNumber
sTemp = .Value
iX = InStr(sTemp, "X")
.Value = Right(sTemp, Len(.Value) - iX)
.Offset(0, 1).Value = Left(sTemp, iX)
End With
Next
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=rData.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rDataHeaders
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For Each rNumber In rData.Columns(1).Cells
With rNumber
.Value = .Offset(0, 1).Value & .Value
End With
Next
ws.Range("B3", Range("B3").End(xlDown)).Delete Shift:=xlToLeft
Application.ScreenUpdating = True
'----------------------------------------------------------------------------------------------------
Obfuscated
10-10-2016, 02:23 AM
That worked GREAT. Thank you very much.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.