VBA code to auto sort numbers

[Lil Stinker]

I have three set ranges of cells on a sheet that will have numbers in them that I would like to have sorted when the macro is run.

First range is B24:O38, second range is P24:Q38 and the third is R24:S38. They sit right next to each other with no headers for which to base the sort. While the ranges are set, the numbers within those ranges are not. For instance, B24:O38 has 210 cells. Not all 210 cells will always have a value in them so the macro should be dynamic. When numbers are entered in these ranges, they are entered left to right from B24 to O24, down to the next row B25 to O25, etc. until O38 is reached.

I would simply like for the numbers to be sorted in numeric value and still display in left to right order without any spaces popping up. Some of the numbers may also start with a letter or contain a letter within.

I feel like this can be achieved through VBA but not with my limited understanding of it. Any help would be appreciated.

Below is a sample of how the form looks...

2-21 mrexcelTEST.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
23		SERIAL NUMBERS			Main											Secondary		Misc
24		5102	5343	5138	8183	9454	8717	8916	8371	8592	8709	7793	8190	7269	5194	321	223	A123	A223
25		8079	7328	5003	8275	9106	4836	7128	4728	8689	8897	8403	5545	8392	6812	524	657	A405	A324
26		8067														101		A100
27
28
29
30
31
32
33
34
35
36
37
38
TEST

 

[bebo021999]

This code is worksheet_change event: Any change in range B24:S38 will be triggerred then sort from A-Z, left to right (based on value within alphabet-number string)

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, j&, k&, c&, m&, val, tmp1, tmp2, rng, arr(1 To 210, 1 To 2), res()
If Intersect(Target, Range("B24:S38")) Is Nothing Then Exit Sub
c = Target.Column
rng = Range(IIf(c < 16, "B24:O38", IIf(c < 18, "P24:Q38", "R24:S38"))).Value
ReDim res(1 To UBound(rng), 1 To UBound(rng, 2))

'copy value into array "arr"
For i = 1 To UBound(rng)
    For j = 1 To UBound(rng, 2)
        If Not IsEmpty(rng(i, j)) Then
            val = "": k = k + 1: arr(k, 2) = rng(i, j)
            For m = 1 To Len(rng(i, j))
                If IsNumeric(Mid(rng(i, j), m, 1)) Then val = val & Mid(rng(i, j), m, 1)
            Next
            arr(k, 1) = CLng(val)
        End If
    Next
Next

'sort arr A-Z
For i = 1 To k - 1
    For j = i + 1 To k 'i + 1 To UBound(arr)
        If arr(i, 1) > arr(j, 1) Then
            tmp1 = arr(i, 1): tmp2 = arr(i, 2)
            arr(i, 1) = arr(j, 1): arr(i, 2) = arr(j, 2)
            arr(j, 1) = tmp1: arr(j, 2) = tmp2
        End If
    Next
Next

'copy 1D arr to 2D array
For i = 1 To k
    res(Int((i - 1) / UBound(rng, 2)) + 1, (i - 1) Mod UBound(rng, 2) + 1) = arr(i, 2)
Next
Application.EnableEvents = False
Range(IIf(c < 16, "B24", IIf(c < 18, "P24", "R24"))).Resize(UBound(res), UBound(res, 2)).Value = res
Application.EnableEvents = True
End Sub

Book1.xlsm

docs.google.com

 

[Lil Stinker]

Thank you for this! I can't even pretend to know what's going on here but it seems to work well. Question: what is happening here? I'd just like to have a basic understanding of what's going on for future error handling or conflicts. For instance, I also have a worksheet change_event running that notifies the user once they've reached the end of each section (O38, Q38 and S38) so they don't end up overwriting any of their entries. When I tested this, I got a type: mismatch error (I'm assuming because I only entered a space in O38). As long as I enter a number, there doesn't seem to be any issue.

Could this code be used in a standard module so it can be run after the numbers are entered all at once instead of a worksheet_change event?

 

[bebo021999]

Thank you for this! I can't even pretend to know what's going on here but it seems to work well. Question: what is happening here? I'd just like to have a basic understanding of what's going on for future error handling or conflicts. For instance, I also have a worksheet change_event running that notifies the user once they've reached the end of each section (O38, Q38 and S38) so they don't end up overwriting any of their entries. When I tested this, I got a type: mismatch error (I'm assuming because I only entered a space in O38). As long as I enter a number, there doesn't seem to be any issue.

Could this code be used in a standard module so it can be run after the numbers are entered all at once instead of a worksheet_change event?

My code can be placed in general module, but you need a button click to activate it.
It seems you have other worksheet change event already?
Could you post it here?

 

[bebo021999]

BTW, this is how my code works:
Any change in range B24:O38 will be triggered to activate the code.
after any input value done, all value in range will be store in an array, then sort A-Z, then paste back into range, one after one, no blank cell within, from left to right, up to bottom

 

[Lil Stinker]

My code can be placed in general module, but you need a button click to activate it.
It seems you have other worksheet change event already?
Could you post it here?

Just basic code that pulls up a user form message to grab the user's attention.

If Not Intersect(Target, Range("O38")) Is Nothing And Range("O38").Value <> Empty Then
    UserForm1.Show
End If
If Not Intersect(Target, Range("Q38")) Is Nothing And Range("Q38").Value <> Empty Then
    UserForm1.Show
End If
If Not Intersect(Target, Range("S38")) Is Nothing And Range("S38").Value <> Empty Then
    UserForm1.Show
End If

BTW, this is how my code works:
Any change in range B24:O38 will be triggered to activate the code.
after any input value done, all value in range will be store in an array, then sort A-Z, then paste back into range, one after one, no blank cell within, from left to right, up to bottom

I had a feeling that's what it was doing. I'm just not advanced enough to understand the code.
Works brilliantly!

 

[bebo021999]

If target was O38,Q38,S38 and not empty value then pop up UserForm, at beginning lines, marks notify with "true":

If Intersect(Target, Range("B24:S38")) Is Nothing Then Exit Sub

'new line added .....
If Not Intersect(Target, Range("O38,Q38,S38")) Is Nothing And Not IsEmpty(Target) Then notify = True
'----------

At the end, check the notify, then action.

Application.EnableEvents = True

'new line added
If notify Then UserForm1.Show
End Sub

The coplete code should be:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, j&, k&, c&, m&, val, tmp1, tmp2, rng, arr(1 To 210, 1 To 2), res()
Dim notify As Boolean ' new varialble
If Intersect(Target, Range("B24:S38")) Is Nothing Then Exit Sub

'new line added .....
If Not Intersect(Target, Range("O38,Q38,S38")) Is Nothing And Not IsEmpty(Target) Then notify = True
'----------

c = Target.Column
rng = Range(IIf(c < 16, "B24:O38", IIf(c < 18, "P24:Q38", "R24:S38"))).Value
ReDim res(1 To UBound(rng), 1 To UBound(rng, 2))

'copy value into array "arr"
For i = 1 To UBound(rng)
    For j = 1 To UBound(rng, 2)
        If Not IsEmpty(rng(i, j)) Then
            val = "": k = k + 1: arr(k, 2) = rng(i, j)
            For m = 1 To Len(rng(i, j))
                If IsNumeric(Mid(rng(i, j), m, 1)) Then val = val & Mid(rng(i, j), m, 1)
            Next
            arr(k, 1) = CLng(val)
        End If
    Next
Next

'sort arr A-Z
For i = 1 To k - 1
    For j = i + 1 To k 'i + 1 To UBound(arr)
        If arr(i, 1) > arr(j, 1) Then
            tmp1 = arr(i, 1): tmp2 = arr(i, 2)
            arr(i, 1) = arr(j, 1): arr(i, 2) = arr(j, 2)
            arr(j, 1) = tmp1: arr(j, 2) = tmp2
        End If
    Next
Next

'copy 1D arr to 2D array
For i = 1 To k
    res(Int((i - 1) / UBound(rng, 2)) + 1, (i - 1) Mod UBound(rng, 2) + 1) = arr(i, 2)
Next
Application.EnableEvents = False
Range(IIf(c < 16, "B24", IIf(c < 18, "P24", "R24"))).Resize(UBound(res), UBound(res, 2)).Value = res
Application.EnableEvents = True

'new line added
If notify Then UserForm1.Show
End Sub

 

[Lil Stinker]

Thanks for this. Is this a more efficient way to code the change event or is there some improvement to the overall functionality? Just curious because both methods seem to work but mine is repetitive and clearly not well versed.

 

[Lil Stinker]

@bebo021999
Since you are the mastermind behind this auto sort code, I'm wondering if it can be adjusted to include additional ranges based on if a certain condition is met?

Originally we started with ranges B24:O38, P24:Q38 and R24:S38. Is it possible if a helper cell equals TRUE could we include the ranges B95:O127, P95:Q127 and R95:S127 and have them sort across both sections? Section 1 being the original set of ranges, section 2 being the additional set.

The coplete code should be:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, j&, k&, c&, m&, val, tmp1, tmp2, rng, arr(1 To 210, 1 To 2), res()
Dim notify As Boolean ' new varialble
If Intersect(Target, Range("B24:S38")) Is Nothing Then Exit Sub

'new line added .....
If Not Intersect(Target, Range("O38,Q38,S38")) Is Nothing And Not IsEmpty(Target) Then notify = True
'----------

c = Target.Column
rng = Range(IIf(c < 16, "B24:O38", IIf(c < 18, "P24:Q38", "R24:S38"))).Value
ReDim res(1 To UBound(rng), 1 To UBound(rng, 2))

'copy value into array "arr"
For i = 1 To UBound(rng)
    For j = 1 To UBound(rng, 2)
        If Not IsEmpty(rng(i, j)) Then
            val = "": k = k + 1: arr(k, 2) = rng(i, j)
            For m = 1 To Len(rng(i, j))
                If IsNumeric(Mid(rng(i, j), m, 1)) Then val = val & Mid(rng(i, j), m, 1)
            Next
            arr(k, 1) = CLng(val)
        End If
    Next
Next

'sort arr A-Z
For i = 1 To k - 1
    For j = i + 1 To k 'i + 1 To UBound(arr)
        If arr(i, 1) > arr(j, 1) Then
            tmp1 = arr(i, 1): tmp2 = arr(i, 2)
            arr(i, 1) = arr(j, 1): arr(i, 2) = arr(j, 2)
            arr(j, 1) = tmp1: arr(j, 2) = tmp2
        End If
    Next
Next

'copy 1D arr to 2D array
For i = 1 To k
    res(Int((i - 1) / UBound(rng, 2)) + 1, (i - 1) Mod UBound(rng, 2) + 1) = arr(i, 2)
Next
Application.EnableEvents = False
Range(IIf(c < 16, "B24", IIf(c < 18, "P24", "R24"))).Resize(UBound(res), UBound(res, 2)).Value = res
Application.EnableEvents = True

'new line added
If notify Then UserForm1.Show
End Sub