Using VBA arrange value in cells - excel

Question

I have some queries related to the VBA script. I have a large number of data in an excel file These all are formula-based values so I can't use special cell functions as well.
Now I need a VBA script that will arrage the table in a proper way. I need if there is any cell blank then the value in the next cell will move left.
Like the below image.
Currently, I'm using the below code but it's taking too much time as its' looping through the entire database one by one. Is there any better way to perform this?
lastrow = Range("B" & Rows.Count).End(xlUp).Row
Repeat = 4
For cellno = 1 To Repeat
For rowno = 2 To lastrow
'Debug.Print cellno
'Debug.Print rowno
If Range(Col1 & rowno).Value = "" Then
Range(Col2 & rowno).Cut
Range(Col1 & rowno).Select
ActiveSheet.Paste
End If
If Range(Col2 & rowno).Value = "" Then
Range(Col3 & rowno).Cut
Range(Col2 & rowno).Select
ActiveSheet.Paste
End If
If Range(Col3 & rowno).Value = "" Then
Range(Col4 & rowno).Cut
Range(Col3 & rowno).Select
ActiveSheet.Paste
End If
If Range(Col4 & rowno).Value = "" Then
Range(Col5 & rowno).Cut
Range(Col4 & rowno).Select
ActiveSheet.Paste
End If
Next rowno
Next cellno

Answer 1

If you just need the values, and not the underlying formulas, Power Query (available in Windows Excel 2010+ and Office 365) may be a better option. Certainly should be faster.
Select some cell in your original table
Data => Get&Transform => From Table/Range
When the PQ UI opens, navigate to Home => Advanced Editor
Make note of the Table Name in Line 2 of the code.
Replace the existing code with the M-Code below
Change the table name in line 2 of the pasted code to your "real" table name
Examine any comments, and also the Applied Steps window, to better understand the algorithm and steps
The basic algorithm consists of:
Transpose the table
Remove the nulls (blanks) from each column
Transpose the table back
PQ has an easier time removing nulls from columns and collapsing them than from rows
M Code
let
//Change Table name in next line to your actual table (or range) name in your workbook
Source = Excel.CurrentWorkbook(){[Name="Table5"]}[Content],
//Demote the headers, then transpose the table
#"Demoted Headers" = Table.DemoteHeaders(Source),
tt = Table.Transpose(#"Demoted Headers"),
/*convert each column into a list,
remove the nulls from the list,
then recreate the table from the list of columns */
remNulls = let
colNames = Table.ColumnNames(tt),
cols = List.Generate(
()=> [col = List.RemoveNulls(Table.Column(tt,colNames{0})), i=1],
each [i] <= Table.RowCount(tt),
each [col = List.RemoveNulls(Table.Column(tt,colNames{[i]})) , i = [i]+1],
each [col])
in
Table.FromColumns(cols),
//transpose the table back to original and promote the headers
#"Transposed Table" = Table.Transpose(remNulls),
#"Promoted Headers" = Table.PromoteHeaders(#"Transposed Table", [PromoteAllScalars=true]),
//set data types to Text (could do something different if needed)
typeIt = Table.TransformColumnTypes(#"Promoted Headers",
List.Transform(Table.ColumnNames(#"Promoted Headers"),each {_, Text.Type}))
in
typeIt

Answer 2

Moving the data to a Variant Array, looping that, then moving the data back to the range will speed this up a lot.
Since you are dealing with Formulas, use Range.Formula2 to get the data (or Range.Formula if you are not using a version of Excel that supports Dynamic Arrays)
Sub Demoz()
Dim rng As Range
Dim lo As ListObject
Dim dat As Variant
Dim rw As Long, cl As Long, idx As Long
' Get a reference to your Data range
Set rng = Workbooks("YourWorkbook").Worksheets("YourWorksheet").Range("YourDataRange")
' Move data to a Variant Array
' Dynamic Array versions of Excel
dat = rng.Formula2 '
' Non-Dynamic Array versions of Excel
'dat = rng.Formula
' Loop the Data Array
For rw = 1 To UBound(dat, 1)
' Find first blank column in current row
idx = 0
For cl = 1 To UBound(dat, 2)
If dat(rw, cl) = vbNullString Then
idx = cl
Exit For
End If
Next
' If row contains some blanks
If idx > 0 Then
' Loop the row
For cl = 1 To UBound(dat, 2)
' If cell contains data
If dat(rw, cl) <> vbNullString Then
' If cell needs to be moved
If idx < cl Then
' Move cell to the left most empty cell
dat(rw, idx) = dat(rw, cl)
dat(rw, cl) = Empty
idx = idx + 1
End If
End If
Next
End If
Next
' Place results back on sheet
' Dynamic Array versions of Excel
rng.Formula2 = dat
' Non-Dynamic Array versions of Excel
'rng.Formula = dat
End Sub
On my hardware a range of 100,000 rows, 10 columns is processed in about 3 seconds. YMMV

Answer 3

This example combined with what you have may speed up the process a bit, rather than using cut and paste it shifts the data around. Also note the use of IsEmpty.
Sorry I couldn't type up a full working example, computer is on the fritz at the moment and using an email or something was making me lose my concentration while trying.
https://learn.microsoft.com/en-us/office/troubleshoot/excel/loop-through-data-using-macro