answer Sort numbers in numerical and string order

graha_karya · Jun 29th 2019

this is answer for case in link : https://www.ozgrid.com/forum/f…umbers-in-numerical-order

Code

Function Urutkan(ar() As Variant, cl As Long)
 Dim a As Long, b As Long, c As Long
   For a = 1 To UBound(ar, 1)
     For b = a + 1 To UBound(ar, 1)
       If ar(a, cl) > ar(b, cl) Then
         For c = 1 To UBound(ar, 2)
           temp = ar(a, c)
           ar(a, c) = ar(b, c): ar(b, c) = temp
         Next c
       End If
     Next b
  Next a
 End Function
 Sub xx1()
 Dim Rg As Range, Tr As String, x As Variant, ar(), sp, i As Long, ii As Long, ans As String
 Dim r As Long, c As Long, fd As Boolean, dic As Object: Set dic = CreateObject("scripting.dictionary")
 Set Rg = [a1]: Tr = "ARD"
 x = Replace(Rg.Value, " ", "")
 ans = MsgBox("Are you Replace", vbYesNo)
 If ans = vbYes Then
      x = Replace(x, Tr, "")
      fd = True
 Else
      x = x: fd = False
 End If
 sp = Split(x, ",")
 ReDim ar(1 To UBound(sp) + 1, 1 To 2)
 For i = 0 To UBound(sp)
     r = r + 1
     txt = Trim$(sp(i))
     If Not IsNumeric(Right(txt, 1)) Then
       ar(r, 1) = Val(txt)
       ar(r, 2) = Replace(txt, ar(r, 1), "")
     Else
       ar(r, 1) = Val(txt)
     End If
 Next i
  Urutkan ar, 1
      For i = 1 To UBound(ar, 1)
        If Not ar(i, 2) = vbNullString Then
            For ii = i + 1 To UBound(ar, 1)
               If ar(i, 2) > ar(ii, 2) And ar(i, 1) = ar(ii, 1) Then
                  temp = ar(i, 2): ar(i, 2) = ar(ii, 2): ar(ii, 2) = temp
               End If
            Next ii
        End If
      Next i
      For i = 1 To UBound(ar)
        dic(ar(i, 1) & ar(i, 2)) = ""
      Next i
      Erase ar
 For Each v In dic
  If fd = True Then
    If tt = "" Then tt = Tr & v Else tt = tt & "," & Tr & v
  Else
     If tt = "" Then tt = v Else tt = tt & "," & v
  End If
 Next v
 Rg(1, 2).Value = tt
 End Sub

Display More

[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"ssx.png","data-attachmentid":1219768}[/ATTACH]

Colin7 · Jun 29th 2019

Just one thing. The "ARD" reference was only an example. Each time I run this code the reference will be different for example it could be GRSD-9005, GRSD-9006, GRSD-9007a etc or A501, A502 A504a, A504b, A505. Could this code be fixed to allow for this?

Thank you

graha_karya · Jun 29th 2019

finaly you can make UDF like this
only small editing in B1=test(A1;"ARD-") change red text with your text

Code

Function test(ByVal fx As String, Textreplace As String) As String
 Dim x As Variant, sp, i As Long, ii As Long, ans As String
 Dim r As Long, c As Long, fd As Boolean, dic As Object: Set dic = CreateObject("scripting.dictionary")
 Dim tt As String, ar() As Variant
 Application.Volatile
  x = Replace(fx, Textreplace, "")
  If Len(Textreplace) Then
     x = Trim$(Replace(x, Textreplace, ""))
     fd = True
  Else
      x = x: fd = False
  End If
 sp = Split(x, ",")
 ReDim ar(1 To UBound(sp) + 1, 1 To 2)
 For i = 0 To UBound(sp)
     r = r + 1
     txt = Trim$(sp(i))
     If Not IsNumeric(Right(txt, 1)) Then
       ar(r, 1) = Val(txt)
       ar(r, 2) = Replace(txt, ar(r, 1), "")
     Else
       ar(r, 1) = Val(txt)
     End If
 Next i
   Urutkan ar, 1
      For i = 1 To UBound(ar, 1)
        If Not ar(i, 2) = vbNullString Then
            For ii = i + 1 To UBound(ar, 1)
               If ar(i, 2) > ar(ii, 2) And ar(i, 1) = ar(ii, 1) Then
                  temp = ar(i, 2): ar(i, 2) = ar(ii, 2): ar(ii, 2) = temp
               End If
            Next ii
        End If
      Next i
 
      For i = 1 To UBound(ar)
        dic(ar(i, 1) & ar(i, 2)) = ""
      Next i
      Erase ar
 For Each v In dic
 If fd = True Then If tt = "" Then tt = Textreplace & v Else tt = tt & "," & Textreplace & v
 If fd = False Then If tt = "" Then tt = Textreplace & v Else tt = tt & "," & Textreplace & v
 Next v
 test = tt
 End Function
Function Urutkan(ar() As Variant, cl As Long)
 Dim a As Long, b As Long, c As Long
   For a = 1 To UBound(ar, 1)
     For b = a + 1 To UBound(ar, 1)
       If ar(a, cl) > ar(b, cl) Then
         For c = 1 To UBound(ar, 2)
           temp = ar(a, c)
           ar(a, c) = ar(b, c): ar(b, c) = temp
         Next c
       End If
     Next b
  Next a
 End Function

Display More

Colin7 · Jun 29th 2019

Also I am originally pulling these numbers from a range on another sheet and combining them into a string removing blanks. For example Sheet 2 range E16:E416 will be like so:

E16 = GSA-700
E17 = BLANK CELL
E18= BLANK CELL
E19 = GSA-702
E20= GSA-700A
and so on

My overall goal is to combine these cells into a string remove blanks and duplicates and putting in numerical order separated by a comma as below,

GSA-700, GSA-700A, GSA-702.

Hope this helps and thank you again for anything you can do to solve this problem

graha_karya · Jun 29th 2019

see this picture
[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"change.png","data-attachmentid":1219774}[/ATTACH]

Colin7 · Jun 29th 2019

Amazing, thanks very much for this. This is perfect but is there anyway it could run without having to type in the letters each time as I do a lot of these everyday? Also I use a UDF to concatenate the range E16:E416 on another sheet removing blank cells. Could you put this into your code aswell?

Sorry for being a nuisance.

Thank you

graha_karya · Jun 29th 2019

if any range or 1 range edit code

Code

'=test("GSA-",A9:A13)
 Function test(Textreplace As String, fx As Variant) As String
 Dim x As Variant, sp, i As Long, ii As Long, ans As String
 Dim r As Long, c As Long, fd As Boolean, dic As Object: Set dic = CreateObject("scripting.dictionary")
 Dim tt As String, ar() As Variant
  If fx.Count = 1 Then
    If Len(Textreplace) Then
      x = Trim$(Replace(fx.Value, Textreplace, ""))
      fd = True
     Else
       x = fx.Value: fd = False
     End If
  Else
       Rg = fx.Value
       For i = LBound(Rg) To UBound(Rg)
           If Len(Rg(i, 1)) Then
             td = Replace(Rg(i, 1), Textreplace, "")
            If x = "" Then x = td Else x = x & "," & td
           End If
       Next i
 
  End If
 sp = Split(x, ",")
 ReDim ar(1 To UBound(sp) + 1, 1 To 2)
 For i = 0 To UBound(sp)
     r = r + 1
     txt = Trim$(sp(i))
     If Not IsNumeric(Right(txt, 1)) Then
       ar(r, 1) = Val(txt)
       ar(r, 2) = Replace(txt, ar(r, 1), "")
     Else
       ar(r, 1) = Val(txt)
     End If
 Next i
   Urutkan ar, 1
      For i = 1 To UBound(ar, 1)
        If Not ar(i, 2) = vbNullString Then
            For ii = i + 1 To UBound(ar, 1)
               If ar(i, 2) > ar(ii, 2) And ar(i, 1) = ar(ii, 1) Then
                  temp = ar(i, 2): ar(i, 2) = ar(ii, 2): ar(ii, 2) = temp
               End If
            Next ii
        End If
      Next i
 
      For i = 1 To UBound(ar)
        dic(ar(i, 1) & ar(i, 2)) = ""
      Next i
      Erase ar
 For Each v In dic
 If fd = True Then If tt = "" Then tt = Textreplace & v Else tt = tt & "," & Textreplace & v
 If fd = False Then If tt = "" Then tt = Textreplace & v Else tt = tt & "," & Textreplace & v
 Next v
 test = tt
 End Function
Function Urutkan(ar() As Variant, cl As Long)
 Dim a As Long, b As Long, c As Long
   For a = 1 To UBound(ar, 1)
     For b = a + 1 To UBound(ar, 1)
       If ar(a, cl) > ar(b, cl) Then
         For c = 1 To UBound(ar, 2)
           temp = ar(a, c)
           ar(a, c) = ar(b, c): ar(b, c) = temp
         Next c
       End If
     Next b
  Next a
 End Function

Display More

Colin7 · Jun 29th 2019

My only problem is that there are 20 of these formulas on one sheet which pull numbers from different ranges. So I would have to type in the letters to 20 different formulas each time. Is there a way to do this that isn't a UDF and it would automatically put the numbers in numerical order regardless of which letters there are?

Thank you

graha_karya · Jun 29th 2019

1 minute ago
My only problem is that there are 20 of these formulas on one sheet which pull numbers from different ranges. So I would have to type in the letters to 20 different formulas each time. Is there a way to do this that isn't a UDF and it would automatically put the numbers in numerical order regardless of which letters there are?

if you has any or multi range using parramArray

Code

Function test(Textreplace As String, fx As Variant) As String
change to  
[B]Function test1(Textreplace As String, ParamArray fx() As Variant) As String[/B]
but you must edit little code you can do in cell with multi range and multi sheet
[B]= test1("A",shee1A1:a10,sheet2b10:b30,{"F90";"F90";"F90A"})

[/B]
[/code]

Colin7 · Jun 29th 2019

How does this work?

on sheet 1 cell C23 I need the formula =test("GSA-",sheet2,E16:E416)

on sheet 1 cell C13 I need the formula =test("GSA-",sheet2,E520:E920)

on sheet 1 cell C33 I need the formula =test("GSA-",sheet2,E1100:E1500)

and so on

graha_karya · Jun 29th 2019

Quote from Colin7

How does this work?

on sheet 1 cell C23 I need the formula =test("GSA-",sheet2,E16:E416)

on sheet 1 cell C13 I need the formula =test("GSA-",sheet2,E520:E920)

on sheet 1 cell C33 I need the formula =test("GSA-",sheet2,E1100:E1500)

and so on

Display More

i dont understand you want
in post #7 i has edit my code
C23=test("GSA-",sheet2,E16:E416)
C13=test("GSA-",sheet2E520:E920)
C33=test("GSA-",sheet2,E1100:E1500)
[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"cxx.png","data-attachmentid":1219785}[/ATTACH]

Colin7 · Jun 29th 2019

yes your code works perfectly. I was just wondering if it could be adjusted so I did not have to keep retyping the letters into the formulas everytime they changed. Could the code not just order the numbers and disregard the letters in the string?

job 1 the letters could be GSA-
job 2 the letters could be ARD-
job 3 the letters could be TRSQ
etc

Colin7 · Jun 29th 2019

graha_karya,

Thanks for your help on this. Your code is brilliant

answer Sort numbers in numerical and string order

Participate now!

Share