Custom Sort Parts List - VBA

[CC268]

Right now I am doing this manually. I take the parts under the Assembly, copy and paste into another sheet and Custom Sort Columns E, D, F (Sort On: Values, Order: A to Z). I then copy and paste that back into the original spreadsheet. I then move onto the next Assembly. It is a bit of a pain and I know this can be done automatically via VBA. See sample spreadsheet.

Any help is greatly appreciated.

Cross posted here: https://www.excelforum.com/excel-programming-vba-macros/1177126-custom-sort-parts-list-vba.html#post4602370

Thanks.

18593

[Paul_Hossler]

If the data is laid out that nicely, this should work




Option Explicit
Sub CustomSort()
Dim rData As Range, rStart As Range, rEnd As Range, rBlock As Range

'set the data
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion

'clear any empty, but text i.e. 0 length strings
With rData
Call .Replace(vbNullString, "###ZZZ###", LookAt:=xlWhole)
Call .Replace("###ZZZ###", vbNullString, LookAt:=xlWhole)

'clear the settings
.Find What:=vbNullString, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False
.Replace What:=vbNullString, Replacement:=vbNullString, ReplaceFormat:=False
End With

'find PN block
Set rStart = rData.Cells(1, 4).End(xlDown)
Set rEnd = rStart.End(xlDown)

Do
Set rBlock = Range(rStart, rEnd).Resize(, 3)
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rBlock.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rBlock.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rBlock.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rBlock
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set rStart = rEnd.End(xlDown)
Set rEnd = rStart.End(xlDown)

Loop Until rEnd.Row > rData.Rows.Count
End Sub

[SamT]

Sub SortByAssembly()
Dim Cel As Range
Dim SortRange As Range
Dim Tmp As Range
Dim x

For Each Cel In Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
If Cel = "" Then GoTo CelNext

Set SortRange = Cel.Offset(1, 3)

'SortRange.End(xlDown) returns bottom used cell in Column D in this worksheet!?!?
Set Tmp = SortRange
Do While Tmp.Offset(1) <> ""
Set Tmp = Tmp.Offset(1)
Loop

With Range(SortRange, Tmp.Offset(, 2))
.Sort Key1:=.Cells(1), Header:=xlNo
End With

CelNext:
Next Cel

End Sub

[CC268]

Responding to both Paul and Sam - your guys' code both did the same thing...it didn't quite work.

It needs to sort E, D, F...so it should be sorted alphabetically when I look at Column E.

It is weird cause both your guys' code sorts it exactly the same way...but when I look at Column E it is sorted totally random it isn't alphabetical...

[SamT]

on mine, change

Key1:=.Cells(1)
To

Key1:=.Cells(2), Key2:=.Cells(1), Key3:=.Cells(3)

IOW change the key from the first cell in SortRange to the second cell. Note Cells are counted left to right then down.

[CC268]

on mine, change

Key1:=.Cells(1)
To

Key1:=.Cells(2)

IOW change the key from the first cell in SortRange to the second cell. Note Cells are counted left to right then down.

That worked great - is it possible to sort on E then F? Right now it sorts on just E. In some cases I may have a Description (Column E) that says MOTOR and then the different materials in Column F (Material Description) are listed - it would be great to have those in alphabetical order as well (although not completely necessary if we can't get it figured out).

Thanks!

[SamT]

Yer 2 fast.
See my edits in #5

[CC268]

Yer 2 fast.
See my edits in #5

Uhh oh...just realized...it is sorting columns D,E,F...but it isn't sorting all the other columns along with it (columns G-AM). So the corresponding data isn't being sorted with it

[SamT]

What Columns G-AM? are you talking about? You never mentioned them before! They're not in your attachment!

Am I supposed to be looking over your shoulder or reading your mind or something? :bat2:

Assuming that AM is the last used column, change

Tmp.Offset(, 2))
To

Cells(tmp.Row, "AM"))

[CC268]

What Columns G-AM? are you talking about? You never mentioned them before! They're not in your attachment!

Am I supposed to be looking over your shoulder or reading your mind or something? :bat2:

Assuming that AM is the last used column, change

Tmp.Offset(, 2))
To

Cells(tmp.Row, "AM"))

Great thanks for the help - I though that if you'd sorted a single column it would extent the sort range to include all columns in that row as it does with the Sort function in Excel. Sorry.

I guess my last question would be - is there a way to have it automatically find what the last column is instead of hard coding in column "AM"? (Maybe have it look in the first row and see what the last column header is using like a .End(xlRight) command (if that even exists)?

[SamT]

Sub SortByAssembly()
Dim Cel As Range
Dim SortRange As Range
Dim Tmp As Range
Dim LC as Long

LC = Cells(1, Columns.Count).End(xlToLeft).Column
For Each Cel In Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
If Cel = "" Then GoTo CelNext

Set SortRange = Cel.Offset(1, 3)

'SortRange.End(xlDown) returns bottom used cell in Column D in this worksheet!?!?
Set Tmp = SortRange
Do While Tmp.Offset(1) <> ""
Set Tmp = Tmp.Offset(1)
Loop

With Range(SortRange, Cells(Tmp.Row, LC))
.Sort Key1:=.Cells(2), Key2:=.Cells(1), Key3:=.Cells(3)
End With

CelNext:
Next Cel

End Sub
End & (xlUp), (xlDown), (xlToLeft), or (xlToRight). Works just like Ctrl+Arrow Key(s) on the keyboard, hence the comment about End(xDown) not working in this worksheet.

Ponder over the various places a dot (.) is and is not used in front of "Cells." It's critical to understand.

[Paul_Hossler]

Yea, G-AM data would be nice to have known

I changed line <<<<<< to include sorting data to the far right by D, then E, then F

You have to be careful since some cells are not really empty, but include an empty string so .End will not necessarily work as expected. That's why I put the Replace's in






Option Explicit
Sub CustomSort()
Dim rData As Range, rStart As Range, rEnd As Range, rBlock As Range
'set the data
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
'clear any empty, but text i.e. 0 length strings
With rData
Call .Replace(vbNullString, "###ZZZ###", LookAt:=xlWhole)
Call .Replace("###ZZZ###", vbNullString, LookAt:=xlWhole)

'clear the settings
.Find What:=vbNullString, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False
.Replace What:=vbNullString, Replacement:=vbNullString, ReplaceFormat:=False
End With
'find PN block
Set rStart = rData.Cells(1, 4).End(xlDown)
Set rEnd = rStart.End(xlDown)

Do
Set rBlock = Range(rStart, rEnd).Resize(, rData.Parent.UsedRange.Columns.Count) ' <<<<<<<<<<<<<<<<<<<<<
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rBlock.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rBlock.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rBlock.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rBlock
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set rStart = rEnd.End(xlDown)
Set rEnd = rStart.End(xlDown)

Loop Until rEnd.Row > rData.Rows.Count
End Sub