VBA Macro - Sort row (left to right) based on a pre-sorted worksheets

harky · Apr 11th 2019

Hi!
Below i had a Macro (which i got help from someone in other forum) and it work pretty well to what i want BUT i appreciate if someone could help me improve
Could is possible to sort row base on pre-sorted list?

the pre-sorted list is name as "çustomlist" sheet

The code is Left to Right, Excluded the row 1 and col A for header and serial.

"S/N" is in cell A1:

Before:
Sheet4 (2) [TABLE="border: 1"]

[tr]

A B C D E F G H

[/tr]

[tr]

1

[td]

S/M

[/td]

[td][/td]

[/tr]

[tr]

2 [TD="align: right"]1111[/TD]
[TD="align: right"]8846[/TD]
[TD="align: right"]62[/TD]
[TD="align: right"]7688e[/TD]
[TD="align: right"]7688[/TD]
[TD="align: right"]2376[/TD]
[TD="align: right"]6100[/TD]
[TD="align: right"]6100a[/TD]

[/tr]

[tr]

3 [TD="align: right"]1112[/TD]
[TD="align: right"]3086[/TD]

[td][/td]

[TD="align: right"]3086a[/TD]

[td][/td]

[TD="align: right"]ABC[/TD]
[TD="align: right"]8991[/TD]

[td][/td]

[/tr]

[tr]

4 [TD="align: right"]1113[/TD]
[TD="align: right"]6231[/TD]

[td][/td]

[TD="align: right"]8783[/TD]
[TD="align: right"]3663[/TD]

[/tr]

[tr]

5 [TD="align: right"]1114[/TD]
[TD="align: right"]4385[/TD]

[td][/td]

[/tr]

[tr]

6 [TD="align: right"]1115[/TD]
[TD="align: right"]6385[/TD]
[TD="align: right"]4340[/TD]
[TD="align: right"]7264[/TD]
[TD="align: right"]5391[/TD]
[TD="align: right"]3664[/TD]
[TD="align: right"]9705[/TD]
[TD="align: right"]8592[/TD]

[/tr]

[tr]

7 [TD="align: right"]1116[/TD]

[td][/td]

[/tr]

[tr]

8 [TD="align: right"]1117[/TD]
[TD="align: right"]3438[/TD]

[td][/td]

[TD="align: right"]404[/TD]
[TD="align: right"]8346[/TD]
[TD="align: right"]2046[/TD]
[TD="align: right"]6934[/TD]
[TD="align: right"]1023[/TD]

[/tr]

[tr]

9 [TD="align: right"]1118[/TD]
[TD="align: right"]3277[/TD]
[TD="align: right"]7595[/TD]
[TD="align: right"]6314[/TD]
[TD="align: right"]4464[/TD]
[TD="align: right"]1546[/TD]
[TD="align: right"]9917[/TD]
[TD="align: right"]1794[/TD]

[/tr]

[tr]

10 [TD="align: right"]1119[/TD]

[td][/td]

[TD="align: right"]3124[/TD]
[TD="align: right"]8722[/TD]
[TD="align: right"]6554[/TD]
[TD="align: right"]3374[/TD]
[TD="align: right"]9603[/TD]
[TD="align: right"]1234[/TD]

[/tr]

[/TABLE]

After:
Sheet4 (2) [TABLE="border: 1"]

[tr]

A B C D E F G H

[/tr]

[tr]

1

[td]

S/M

[/td]

[td][/td]

[/tr]

[tr]

2 [TD="align: right"]1111[/TD]
[TD="align: right"]62[/TD]
[TD="align: right"]2376[/TD]
[TD="align: right"]6100[/TD]
[TD="align: right"]6100a[/TD]
[TD="align: right"]7688[/TD]
[TD="align: right"]7688e[/TD]
[TD="align: right"]8846[/TD]

[/tr]

[tr]

3 [TD="align: right"]1112[/TD]
[TD="align: right"]ABC[/TD]
[TD="align: right"]3086[/TD]
[TD="align: right"]3086a[/TD]
[TD="align: right"]8991[/TD]

[td][/td]

[/tr]

[tr]

4 [TD="align: right"]1113[/TD]
[TD="align: right"]3663[/TD]
[TD="align: right"]6231[/TD]
[TD="align: right"]8783[/TD]

[td][/td]

[/tr]

[tr]

5 [TD="align: right"]1114[/TD]
[TD="align: right"]4385[/TD]

[td][/td]

[/tr]

[tr]

6 [TD="align: right"]1115[/TD]
[TD="align: right"]3664[/TD]
[TD="align: right"]4340[/TD]
[TD="align: right"]5391[/TD]
[TD="align: right"]6385[/TD]
[TD="align: right"]7264[/TD]
[TD="align: right"]8592[/TD]
[TD="align: right"]9705[/TD]

[/tr]

[tr]

7 [TD="align: right"]1116[/TD]

[td][/td]

[/tr]

[tr]

8 [TD="align: right"]1117[/TD]
[TD="align: right"]404[/TD]
[TD="align: right"]1023[/TD]
[TD="align: right"]2046[/TD]
[TD="align: right"]3438[/TD]
[TD="align: right"]6934[/TD]
[TD="align: right"]8346[/TD]

[td][/td]

[/tr]

[tr]

9 [TD="align: right"]1118[/TD]
[TD="align: right"]1546[/TD]
[TD="align: right"]1794[/TD]
[TD="align: right"]3277[/TD]
[TD="align: right"]4464[/TD]
[TD="align: right"]6314[/TD]
[TD="align: right"]7595[/TD]
[TD="align: right"]9917[/TD]

[/tr]

[tr]

10 [TD="align: right"]1119[/TD]
[TD="align: right"]1234[/TD]
[TD="align: right"]3124[/TD]
[TD="align: right"]3374[/TD]
[TD="align: right"]6554[/TD]
[TD="align: right"]8722[/TD]
[TD="align: right"]9603[/TD]

[/tr]

[/TABLE]

Code

Sub Sort_leftRight_numeric()
Dim WKS As Worksheet
Dim rng2Sort As Range
Dim Index As Long
Dim CalcMode As XlCalculation
CalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set WKS = ActiveSheet ' or by sheet's tab name ThisWorkbook.Worksheets("Sheet4") or just use Codename
Set rng2Sort = WKS.Range("A1").CurrentRegion
Set rng2Sort = rng2Sort.Offset(1, 1).Resize(rng2Sort.Rows.Count - 1, rng2Sort.Columns.Count - 1)
For Index = rng2Sort.Rows.Count To 1 Step -1
With rng2Sort.Rows(Index)
.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlSortRows
End With
Next
Application.Calculation = CalcMode
Application.ScreenUpdating = True
End Sub

Display More

**KjBox** · Apr 11th 2019

What you want should be possible, but not by using ".Sort" since you need a custom sorting order.

Can you confirm that order is

Pure numeric values in ascending order
Part numeric values in ascending order of numeric part, and ascending order of text part for each numeric part
Pure text values in ascending order

Concerning the values that are part numeric & par text, will the text part always be just a single character ("a", "b", "c" etc.) and always after the numeric part?

If you let me have the answers to those questions I will try to get a working code for you.

BTW, if you have posted the required change to the code you were given on the site were that code was provided, please give the link to your post on that site.

**KjBox** · Apr 11th 2019

Quote

Could is possible to sort row base on pre-sorted list?

the pre-sorted list is name as "çustomlist" sheet

What do you mean by pre-sorted list?

Where is the "çustomlist" sheet?

It might be best if you attached your workbook.

To attach a file click the paper clip icon at the top right of the reply box, then click the "Upload Attachments" button that will appear bottom left. Browse to your file and double click it.

harky · Apr 11th 2019

cause this script is not done by me and i not sure will it possible to get it run?

Want to improve the above script on sorting part -> Sorting based on custom sheet @ excel
If any number not found inside this sheet, it will be shift to the last cell?

The original vbc is from this site.
https://www.mrexcel.com/forum/excel-...ight-rows.html

I had Attach the customlist example. Actually there are total of 500 entries
(which manual re-arranged to try it on Sort & Filter -> Custom Lists but entries too large. It hit the max)

**KjBox** · Apr 11th 2019

So every entry in the data that needs sorting will be somewhere in the "Custom List"?

harky · Apr 11th 2019

Hi, i attach the marco with customlist

harky · Apr 11th 2019

Hi,

Yes. the Custom List already manual sorted.
If any number not found inside this sheet, it will be shift to the last cell. (I guess that is the best solution?)
But, if it found on Custom List but not on the data (than ignore)

btw, it sort by horizontal (Left to Right, Excluded the row 1 and col A for header and serial. )

Quote from KjBox

So every entry in the data that needs sorting will be somewhere in the "Custom List"?

**KjBox** · Apr 11th 2019

OK thanks for that, much easier to work with "real" data!

I see from your post in MrExcel that you are in Singapore, I am in Kuching and will look at this tonight and have a solution for you tomorrow morning.

harky · Apr 11th 2019

Hi hehe really appreciate the help.
take ur time

Quote from KjBox

OK thanks for that, much easier to work with "real" data!

I see from your post in MrExcel that you are in Singapore, I am in Kuching and will look at this tonight and have a solution for you tomorrow morning.

**KjBox** · Apr 11th 2019

One last question.

I assume empty cells are to be ignored, so
[TABLE="border: 1, cellpadding: 0, cellspacing: 0"]

[tr]

[TD="width: 106"]01019[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"]NR6[/TD]

[/tr]

[/TABLE]

will sort to
[TABLE="border: 1, cellpadding: 0, cellspacing: 0"]

[tr]

[TD="width: 106"]01019[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]NR6[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]

[/tr]

[/TABLE]

Is that correct?

harky · Apr 11th 2019

Yes. Think there is extra 2.

Should be like this
[TABLE="border: 1, cellpadding: 0, cellspacing: 0"]

[tr]

[TD="width: 106"]01019[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"]NR6[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]

[/tr]

[/TABLE]

Quote from KjBox

One last question.

I assume empty cells are to be ignored, so [TABLE="border: 1, cellpadding: 0, cellspacing: 0"]
[tr]

[TD="width: 106"]01019[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"]NR6[/TD]
[/tr]

[/TABLE]
will sort to [TABLE="border: 1, cellpadding: 0, cellspacing: 0"]
[tr]

[TD="width: 106"]01019[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]NR6[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[/tr]

[/TABLE]
Is that correct?

Display More

**KjBox** · Apr 11th 2019

OK got it now.

harky · Apr 11th 2019

Yes. Think there is extra 2.

Should be like this [TABLE="border: 1, cellpadding: 0, cellspacing: 0"]

[tr]

[TD="width: 106"]01019[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"]NR6[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]

[/tr]

[/TABLE]

Quote from KjBox

One last question.
I assume empty cells are to be ignored, so [TABLE="border: 1, cellpadding: 0, cellspacing: 0"]
[tr]

[TD="width: 106"]01019[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"]NR6[/TD]
[/tr]

[/TABLE]
will sort to [TABLE="border: 1, cellpadding: 0, cellspacing: 0"]
[tr]

[TD="width: 106"]01019[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]6[/TD]
[TD="width: 117"]89e[/TD]
[TD="width: 117"]2[/TD]
[TD="width: 117"]NR6[/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[TD="width: 117"] [/TD]
[/tr]

[/TABLE]
Is that correct?

Display More

**KjBox** · Apr 11th 2019

Extra 2 was my mistake!

**KjBox** · Apr 11th 2019

Try the attached version of your sample file. Note I added 3 values ("Bad1", "Bad2", "Bad3") in order to test values that were not in the "Custom List"

Code assigned to button

Code

Option Explicit
Sub CustomSort()
Dim x, y(), z(), List, data(), i As Long, ii As Long, iii As Long, ly As Long, lz As Long
List = Sheets("customlist").Columns(1).SpecialCells(2)
With ActiveSheet.Cells(1).CurrentRegion.Resize(, 50)
x = .Value2
For i = 2 To UBound(x, 1)
Erase y: ly = 0: lz = 0
For ii = 2 To UBound(x, 2)
If x(i, ii) <> "" Then
If Not IsError(Application.Match(x(i, ii), List, 0)) Then
ly = ly + 1: ReDim Preserve y(1 To ly)
y(ly) = Application.Match(x(i, ii), List, 0)
Else
lz = lz + 1: ReDim Preserve z(1 To lz): z(lz) = x(i, ii)
End If
x(i, ii) = ""
End If
Next
Call ArraySort(y, 1, ly)
If lz = 0 Then
ReDim data(1 To ly)
For iii = 1 To UBound(data)
x(i, iii + 1) = List(y(iii), 1)
Next
Else
Call ArraySort(z, 1, lz)
ReDim data(1 To ly)
For iii = 1 To UBound(data)
x(i, iii + 1) = List(y(iii), 1)
Next
For iii = 1 To lz
ReDim Preserve data(1 To UBound(data) + 1)
x(i, UBound(data)) = z(iii)
Next
End If
Next
.Value2 = x
End With
End Sub
Public Sub ArraySort(x, inLow As Long, inHi As Long)
Dim pivot, tmpSwap, lLow As Long, lHigh As Long
lLow = inLow
lHigh = inHi
pivot = x((inLow + inHi) \ 2)
While (lLow <= lHigh)
While (x(lLow) < pivot And lLow < inHi)
lLow = lLow + 1
Wend
While (pivot < x(lHigh) And lHigh > inLow)
lHigh = lHigh - 1
Wend
If (lLow <= lHigh) Then
tmpSwap = x(lLow)
x(lLow) = x(lHigh): x(lHigh) = tmpSwap
lLow = lLow + 1: lHigh = lHigh - 1
End If
Wend
If (inLow < lHigh) Then ArraySort x, inLow, lHigh
If (lLow < inHi) Then ArraySort x, lLow, inHi
End Sub

Display More

harky · Apr 12th 2019

Hi, I had an error @

it say: Run-time error '9': subscript out of range

when i debug, it show highlight on this line.

pivot = x((inLow + inHi) \ 2)

Quote from KjBox

Try the attached version of your sample file. Note I added 3 values ("Bad1", "Bad2", "Bad3") in order to test values that were not in the "Custom List"

Code assigned to button

Code

Option Explicit

Sub CustomSort()

Dim x, y(), z(), List, data(), i As Long, ii As Long, iii As Long, ly As Long, lz As Long

List = Sheets("customlist").Columns(1).SpecialCells(2)

With ActiveSheet.Cells(1).CurrentRegion.Resize(, 50)

x = .Value2

For i = 2 To UBound(x, 1)

Erase y: ly = 0: lz = 0

For ii = 2 To UBound(x, 2)

If x(i, ii) <> "" Then

If Not IsError(Application.Match(x(i, ii), List, 0)) Then

ly = ly + 1: ReDim Preserve y(1 To ly)

y(ly) = Application.Match(x(i, ii), List, 0)

Else

lz = lz + 1: ReDim Preserve z(1 To lz): z(lz) = x(i, ii)

End If

x(i, ii) = ""

End If

Next

Call ArraySort(y, 1, ly)

If lz = 0 Then

ReDim data(1 To ly)

For iii = 1 To UBound(data)

x(i, iii + 1) = List(y(iii), 1)

Next

Else

Call ArraySort(z, 1, lz)

ReDim data(1 To ly)

For iii = 1 To UBound(data)

x(i, iii + 1) = List(y(iii), 1)

Next

For iii = 1 To lz

ReDim Preserve data(1 To UBound(data) + 1)

x(i, UBound(data)) = z(iii)

Next

End If

Next

.Value2 = x

End With

End Sub

Public Sub ArraySort(x, inLow As Long, inHi As Long)

Dim pivot, tmpSwap, lLow As Long, lHigh As Long

lLow = inLow

lHigh = inHi

pivot = x((inLow + inHi) \ 2)

While (lLow <= lHigh)

While (x(lLow) < pivot And lLow < inHi)

lLow = lLow + 1

Wend

While (pivot < x(lHigh) And lHigh > inLow)

lHigh = lHigh - 1

Wend

If (lLow <= lHigh) Then

tmpSwap = x(lLow)

x(lLow) = x(lHigh): x(lHigh) = tmpSwap

lLow = lLow + 1: lHigh = lHigh - 1

End If

Wend

If (inLow < lHigh) Then ArraySort x, inLow, lHigh

If (lLow < inHi) Then ArraySort x, lLow, inHi

End Sub

Display More

**KjBox** · Apr 12th 2019

With the file I attached or with the code copy/pasted to your actual file?

harky · Apr 12th 2019

after i copy with my actual file...

Quote from KjBox

With the file I attached or with the code copy/pasted to your actual file?

harky · Apr 12th 2019

hmmm, after i update the customlist with actual entries of (maybe 500).
The error is gone.

But could u fix that? it seen like number found on data which is not found on customlist are not shifted to the last cell? (nt sure but this is what i guess)

Quote from KjBox

With the file I attached or with the code copy/pasted to your actual file?

harky · Apr 12th 2019

one more thing, i notice if i run the marco more than 1 time, the "bad1'' (which is not found on customlist) is actually delete the data and shift forward.
it suppose not allow to delete.

Share