sort the pairs

have an list of numbres  in pair

need sort  this order  2 4 6 8 9 0

after click an button need see the result in column E

b1b2.PNG





Thanks in advanced
and Very Happy New Year!!
54565758.xlsx
ADRIANA PACCOUNTING ASSISTANTAsked:
Who is Participating?
 
Ryan ChongConnect With a Mentor Commented:
try customize this:

Sub test()
    Dim StartRow As Integer, LastRow As Integer, tmpArr() As String, idx As Integer
    StartRow = 7
    LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
    
    'Clear cells
    ActiveSheet.Range("E" & StartRow & ":E" & LastRow).Cells.Clear
    
    idx = 0
    
    For i = StartRow To LastRow + 1
        If ActiveSheet.Cells(i, "B") = "" Then
            CustomeSortArray tmpArr
            ActiveSheet.Cells(i - 1, "E") = "'" & Join(tmpArr, "")
            idx = 0
            ReDim tmpArr(idx)
        Else
            ReDim Preserve tmpArr(idx)
            tmpArr(idx) = ActiveSheet.Cells(i, "B")
            idx = idx + 1
        End If
    Next i
End Sub

Function CustomeSortArray(ByRef arr() As String)
    Dim tmp1 As String, tmp2 As String
    SortArray arr
    For x = LBound(arr) To UBound(arr)
        For y = x To UBound(arr)
            If UCase(arr(x)) = "00" Then
                tmp1 = arr(x)
                tmp2 = arr(y)
                arr(x) = tmp2
                arr(y) = tmp1
            End If
        Next y
    Next x
End Function

Sub SortArray(ByRef arr() As String)
    Dim tmp1 As String, tmp2 As String
    For x = LBound(arr) To UBound(arr)
        For y = x To UBound(arr)
            If UCase(arr(y)) < UCase(arr(x)) Then
                tmp1 = arr(x)
                tmp2 = arr(y)
                arr(x) = tmp2
                arr(y) = tmp1
            End If
        Next y
    Next x
End Sub

Open in new window

54565758_b.xlsm
1
 
ADRIANA PACCOUNTING ASSISTANTAuthor Commented:
Ryan Chong   Great Job !!

I like you solution

i would like to ask to you if posible to add an clean or delete button

because i will need change data very fast as needed

Im agreed to open an new question for it
0
 
Ryan ChongCommented:
i would like to ask to you if posible to add an clean or delete button

in my existing codes, there's a part to clear the cells in column E.

see if that serve the purpose?

'Clear cells
ActiveSheet.Range("E" & StartRow & ":E" & LastRow).Cells.Clear

Open in new window

0
Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
ADRIANA PACCOUNTING ASSISTANTAuthor Commented:
Ryan Chong  thats  great

but i need change data in  column B  as needed

i mean need clean all over and change data

i will open an new question for it
0
 
ADRIANA PACCOUNTING ASSISTANTAuthor Commented:
Ryan Chong  Great Job !

Working as Needed Great  Expert !!
0
 
Ryan ChongCommented:
for this question, you could use this for better handling:

Sub test()
    Dim StartRow As Integer, LastRow As Integer, tmpArr() As String, idx As Integer
    StartRow = 7
    LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
   
    'Clear cells
    ActiveSheet.Range("E" & StartRow & ":E" & LastRow).Cells.Clear
   
    idx = 0
   
    For i = StartRow To LastRow + 1
        If ActiveSheet.Cells(i, "B") = "" Then
            If idx > 0 Then
                CustomeSortArray tmpArr
                ActiveSheet.Cells(i - 1, "E") = "'" & Join(tmpArr, "")
                idx = 0
                ReDim tmpArr(idx)
            End If
        Else
            ReDim Preserve tmpArr(idx)
            tmpArr(idx) = ActiveSheet.Cells(i, "B")
            idx = idx + 1
        End If
    Next i
End Sub
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.