Solved: Delete Column if row is blank

[Emoncada]

I have multple spreadsheets that have data with column headers.
I would like for a script to look at row 2 of each column from A:W, and if it's empty to delete the entire column.

Now that is the first part.
After that is done I should just have a few columns with data in row 2 and possibly more rows.

I need to look at the second column (B) and cut from row 1 to the last row of data and paste it in column (A) leaving a row empty. And continue to do this with all columns with data in row 2.

So I should have all the data from the columns now in Column A


Can this be done?

[mancubus]

does this help?


Sub DelColsBlnkCll()

Dim ws As Worksheet
Dim Col As Long, LastCol As Long

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With

For Each ws In Worksheets
With ws
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
For Col = LastCol To 1 Step -1
If Trim(.Cells(2, Col).Value) = "" Then .Columns(Col).EntireColumn.Delete
Next
.Columns(1).EntireColumn.Delete
'column B cut from row 1 to the last row of data and paste it in column A
.Rows(1).EntireRow.Insert
'leaving a row empty
End With
Next

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = Calc
End With

End Sub

[Emoncada]

hi mancubus, thanks for the quick reply.
Your script does delete the columns without a value in row 2 with exception to the last column.
Also it does not put the values in column A instead it's just moving all the values down 1 row so row 1 is all blank and headers are in row 2

[mancubus]

you're wellcome.

and i'm sorry, i completely misunderstood the requirement.

give this a try:

Sub DelColsBlnkCllThenMove()

Dim ws As Worksheet
Dim moveRng As Range, destRng As Range
Dim Calc as Long, Col As Long, LastCol As Long

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With

For Each ws In Worksheets
With ws
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Col = LastCol To 1 Step -1
If Trim(.Cells(2, Col).Value) = "" Then .Columns(Col).EntireColumn.Delete
Next
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
If LastCol = 1 Then Exit Sub
For Col = 2 To LastCol
Set destRng = .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0)
Set moveRng = .Range(.Cells(1, Col), .Cells(.Cells(.Rows.Count, Col).End(xlUp).Row, Col))
moveRng.Cut Destination:=destRng
Next
End With
Next

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = Calc
End With

End Sub

[Emoncada]

looks good, but I noticed it does it for all the spreadsheets, can i have just do this on active sheet?

[mancubus]

hey.
this was not a part of the misunderstanding. :think: :rotlaugh:

I have multple spreadsheets that have data with column headers.





Sub DelColsBlnkCllThenMove()

Dim moveRng As Range, destRng As Range
Dim Calc As Long, Col As Long, LastCol As Long

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With

With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Col = LastCol To 1 Step -1
If Trim(.Cells(2, Col).Value) = "" Then .Columns(Col).EntireColumn.Delete
Next
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
If LastCol = 1 Then Exit Sub
For Col = 2 To LastCol
Set destRng = .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0)
Set moveRng = .Range(.Cells(1, Col), .Cells(.Cells(.Rows.Count, Col).End(xlUp).Row, Col))
moveRng.Cut Destination:=destRng
Next
End With

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = Calc
End With

End Sub

[Emoncada]

yes your right, only thing is this is a spreadsheet that gets added to on a weekly basis. so it would be better to select which one we need at that time and not redo one's that have previously been done.

[Emoncada]

This looks good mancubus Thanks

[mancubus]

you're wellcome.
glad it helped...