VBA macro to sort columns data

[Yamasaki450]

Hey guys.

Sorry to bother you again but i need another macro to sort columns data like shown on screenshot. I have to mention i have large amount of data to sort its about 15 million cells so i need macro to be fast as possible...

Thanks.

 

[Akuini]

Try this on a copy of your data:

Sub Yamasaki450_1()
Dim i As Long, j As Long, k As Long
Dim va, vb
Dim c As Range
Dim t As Double

t = Timer
Set c = Range("B2:D15")  'change the range to suit
va = c
ReDim vb(1 To UBound(va, 1), 1 To UBound(va, 2))

For j = 1 To UBound(va, 2)
    k = UBound(va, 1)
    For i = UBound(va, 1) To 1 Step -1
        If va(i, j) <> Empty Then
            vb(k, j) = va(i, j)
            k = k - 1
        End If
    Next
Next

c = vb
Debug.Print "Completion time:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

 

[kevin9999]

Did you try the code in post #19 on VBA macro to delete highlighted cells

 

[Yamasaki450]

Try this on a copy of your data:

Sub Yamasaki450_1()
Dim i As Long, j As Long, k As Long
Dim va, vb
Dim c As Range
Dim t As Double

t = Timer
Set c = Range("B2:D15")  'change the range to suit
va = c
ReDim vb(1 To UBound(va, 1), 1 To UBound(va, 2))

For j = 1 To UBound(va, 2)
    k = UBound(va, 1)
    For i = UBound(va, 1) To 1 Step -1
        If va(i, j) <> Empty Then
            vb(k, j) = va(i, j)
            k = k - 1
        End If
    Next
Next

c = vb
Debug.Print "Completion time:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

I tried this code and its really fast it only takes a minute to sort 15 million cells... But all cells with value 0 are missing... Is this possible to fix?

 

[Yamasaki450]

Did you try the code in post #19 on VBA macro to delete highlighted cells

Yes i did try your code but there i asked you to extend existing code. Your code works just fine but i still need separate code for sorting and separate for highlighting cells. I will open new thread for this...
I also tried only the sorting part of your code (in post #19) separately but it doesnt work correct in this case shown on screenshot. Thats why im asking for new one.

 

[Akuini]

But all cells with value 0 are missing... Is this possible to fix?

Ah, sorry about that.
We need to change If va(i, j) <> Empty Then to If va(i, j) <> "" Then
So, use this one:

Sub Yamasaki450_2()
Dim i As Long, j As Long, k As Long
Dim va, vb
Dim c As Range
Dim t As Double

t = Timer
Set c = Range("B2:D15")  'change the range to suit
va = c
ReDim vb(1 To UBound(va, 1), 1 To UBound(va, 2))

For j = 1 To UBound(va, 2)
    k = UBound(va, 1)
    For i = UBound(va, 1) To 1 Step -1
        If va(i, j) <> "" Then
            vb(k, j) = va(i, j)
            k = k - 1
        End If
    Next
Next

c = vb
Debug.Print "Completion time:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

 

[Yamasaki450]

Ah, sorry about that.
We need to change If va(i, j) <> Empty Then to If va(i, j) <> "" Then

Now it works. Thanks a lot for your help man... Great support on this forum...

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.