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

 

[Fluff]

How about

Sub chk()
   Dim Cols As Long
   Dim i As Long
   
   Cols = ActiveSheet.UsedRange.Columns.Count
   For i = 1 To Cols Step 6
      On Error Resume Next
      Cells(1, i).Resize(, 4).EntireColumn.SpecialCells(xlBlanks).Delete xlShiftUp
      On Error GoTo 0
   Next i
End Sub

 

[marsow]

Hi @Fluff,

Tried your code. It still takes too long (over 2 minutes) and, somehow rolls back the changes.

 

[Fluff]

What do you mean by

somehow rolls back the changes.

 

[marsow]

@Fluff,

I can see the code compacting the data to the top. But, the data goes back to how they originally were at the very end.

I hope this makes sense?

 

[marsow]

@Fluff,

Sorry sir, pls disregard that. It worked the second time.
Do you think we can make your code work about 3x faster? It still takes too long. The actual data can go as far as column 'DK' and down to 600.

 

[Fluff]

Add the line in red

Sub chk()
   Dim Cols As Long
   Dim i As Long
[COLOR=#ff0000]Application.ScreenUpdating = False[/COLOR]
   Cols = ActiveSheet.UsedRange.Columns.Count
   For i = 1 To Cols Step 6
      On Error Resume Next
      Cells(1, i).Resize(, 4).EntireColumn.SpecialCells(xlBlanks).Delete xlShiftUp
      On Error GoTo 0
   Next i
End Sub

should speed it up a bit

 

[marsow]

Thank you for your code @Fluff. I will use this for now.
But, I am still hoping for a much faster code to come. Like a tweaked version of what I had originally.

 

[Fluff]

How about

Sub chk()
   Dim ary As Variant, Nary As Variant
   Dim i As Long, r As Long, c As Long
   Dim lr As Long, j As Long
      
   For i = 1 To ActiveSheet.UsedRange.Columns.Count Step 6
      lr = Cells(Rows.Count, i).End(xlUp).Row
      ary = Range(Cells(1, i), Cells(lr, i + 3))
      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
      Range(Cells(1, i), Cells(lr, i + 3)).ClearContents
      Cells(1, i).Resize(UBound(Nary), 4).Value = Nary
   Next i
End Sub

 

[kvsrinivasamurthy]

Post deleted