Please Help With Shift Data Up Macro

[marsow]

Hi everyone,


Please help me with a little code that I have. I am hoping we can tweak it a little. I have a sheet that has columns grouped by 4 and separated by 2 blank columns. The data goes far to the right and is only 600 rows deep. The idea is to move all scattered data to the top leaving no more blank cells as a result. The code below is effective and very fast. But will only work for the first group of 4 columns from A1.

I really need to make this work because all other code I've tried for this just takes way, way too long.

I'm no expert in VBA but I can only go as far as the code here. How can we modify it to make it move all data to the top for all the columns in a bigger range?

Sub ShiftDataUp()

Dim y, z
y = Range("a139"): iii = 1
ReDim z(1 To UBound(y, 1), 1 To UBound(y, 2))
For i = 1 To UBound
If Not IsEmpty(y(i, 1)) Then
For ii = 1 To UBound(y, 2)
z(iii, ii) = y(i, ii)
Next
iii = iii + 1
End If
Next
Range("a139").ClearContents
For i = 1 To UBound(y, 1)
For ii = 1 To UBound(y, 2)
Cells(i, ii) = z(i, ii)
Next
Next

End Sub

 

[marsow]

Holy smoke!
@Fluff, Thank you very much! That one did it. This is exactly what I am hoping for. It does the job at lightning speed.
I think my eyes almost popped out when I saw it work.

Thank you again @Fluff! ray: And, thank you to everyone here at Mr.Excel
Cheers!

 

[JoeMo]

Just curious to know if this works (untested) and if so how does the speed compare to the solution Fluff provided in Post #9 .

Sub ShiftDataUp()
Dim R As Range, Ra As Range
Set R = ActiveSheet.UsedRange
On Error Resume Next
Set Ra = R.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not Ra Is Nothing Then
    Application.ScreenUpdating = False
    Ra.Delete shift:=xlUp
End If
Application.ScreenUpdating = True
End Sub

 

[kvsrinivasamurthy]

Try this code faster one.

Sub RemoveBlankRos()Application.ScreenUpdating = False
Dim LC As Long, T As Long
LC = ActiveSheet.UsedRange.Columns.Count


For T = 1 To LC Step 6
    LR = Cells(Rows.Count, T).End(xlUp).Offset(1, 0).Row
    For TA = 1 To LR
    If Cells(TA, T + 3) <> "" Then Cells(TA, T + 4) = TA
    Next TA
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A:A").Offset(0, T + 3) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range(Cells(1, T), Cells(1, T + 4)).EntireColumn
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


Cells(1, T + 4).EntireColumn.ClearContents


Next T
Application.ScreenUpdating = True
End Sub

 

[Fluff]

@JoeMo
It works for me, with the code from post#9 taking ~0.1 sec & yours taking ~2.6

EDIT:
code from kvsrinivasamurthy takes ~.3 sec

 

[JoeMo]

@JoeMo
It works for me, with the code from post#9 taking ~0.1 sec & yours taking ~2.6

EDIT:
code from kvsrinivasamurthy takes ~.3 sec

Thanks Fluff. Consistent with my experience that avoiding actual row/cell deletions by assembling the output in an array, clearing existing contents and then writing the array is often much faster.

 

[marsow]

@Fluff, @kvsrinivasamurthy, your codes are awesome and you guys are amazing. I think @Fluff's time record is accurate.

But, I ran into a limitation. I hope you can still help? It won't work for data that is 38 columns apart. Sorry, I didn't realize that I had this scenario earlier.

 

[marsow]

@JoeMo, thanks for your code. I tried it too but it was also too slow.
I appreciate your help.

 

[Fluff]

How about

Sub RemoveBlanks()
   Dim ary As Variant, Nary As Variant
   Dim i As Long, R As Long, c As Long
   Dim lr As Long, j As Long
   Dim Ar As Areas, Rng As Range
   Dim Dic As Object
   
   Set Ar = ActiveSheet.UsedRange.SpecialCells(xlConstants).Areas
   Set Dic = CreateObject("scripting.dictionary")
   For Each Rng In Ar
      If Not Dic.exists(Split(Rng.Address, "$")(1)) Then Dic.Add Split(Rng.Address, "$")(1), Nothing
   Next Rng
   For i = 0 To Dic.Count - 1
      lr = Cells(Rows.Count, Dic.Keys()(i)).End(xlUp).Row
      ary = Range(Dic.Keys()(i) & "1").Resize(lr, 4)
      ReDim Nary(1 To UBound(ary), 1 To 4)
      j = 1
      For R = 1 To UBound(ary, 1)
         If Not IsEmpty(ary(R, 1)) Then
            For c = 1 To 4
               Nary(j, c) = ary(R, c)
            Next c
            j = j + 1
         End If
      Next R
      Columns(Dic.Keys()(i)).Resize(, 4).ClearContents
      Range(Dic.Keys()(i) & "1").Resize(UBound(Nary), 4).Value = Nary
   Next i
End Sub

 

[marsow]

Perfection! Thank you @Fluff!

 

[Fluff]

Glad we could help & thanks for the feedback