VBA Delete Empty Cells with Multiple Column Selection

Question

I am having a small amount of trouble with finding a possible solution to a potential problem of mine. I am writing a macro for my supervisor using VBA so that she can just click a button assigned to this macro and follow the directions and get the data she needs. The issue I'm running into is when the macro pastes the data, it has trouble deleting empty cells if the user selects multiple columns.

Sub DataPull()
' Written by Agony
' Data Pull macro
Dim rng1 As Range
Dim rng2 As Range
Dim chc1
Dim chc2
Dim wb1 As Workbook
Dim wb2 As Workbook

'Choose file to get data
chc1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file to pull data from")
If chc1 = False Then Exit Sub

'Choose file to paste data
chc2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file to paste data to")
If chc2 = False Then Exit Sub

'Open first file and copy range
Set wb1 = Workbooks.Open(chc1)
Set rng1 = Application.InputBox("Select cells to transfer", "Selection", "Use your mouse/pointer to select the cells", Type:=8)
rng1.Copy
wb1.Close SaveChanges:=False

'Open second file and paste with specs
Set wb2 = Workbooks.Open(chc2)
Set rng2 = Range("A1")
rng2.PasteSpecial
With Selection.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
With Selection.Font
    .Name = "Cambria"
    .Size = 12
    .TintAndShade = 0
End With

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

'Loop to delete empty cells
Dim i As Long
Dim rows As Long
Dim rng3 As Range
Set rng3 = ActiveSheet.Range("A1:Z50")
rows = rng3.rows.Count
For i = rows To 1 Step (-1)
    If WorksheetFunction.CountA(rng3.rows(i)) = 0 Then rng3.rows(i).Delete
Next

wb2.Activate
MsgBox ("Macro Complete")
End Sub

As above shows, the range is currently tentative. I would like the function to delete cells that are empty if the user selects a range with multiple columns. I've tried using Len for the cells, but that doesn't seem to work either. Any help is greatly appreciated. Thanks!

Answer 1

I don't think you can use the .Copy and .Paste when the source workbook is closed.

I think that whatever you're copying gets lost when the workbook is closed.

So a possible solution to your problem would be to close the wb1 at the end of your macro and not immediately after the copy command.

So move wb1.Close SaveChanges:=False to after this block

...
'Open second file and paste with specs
Set wb2 = Workbooks.Open(chc2)
Set rng2 = Range("A1")
rng2.PasteSpecial
With Selection.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
With Selection.Font
    .Name = "Cambria"
    .Size = 12
    .TintAndShade = 0
End With
wb1.Close SaveChanges:=False ' moved it here
...

---

Deletetion

Try this sub see if this is what you want. What this does it finds the last column used in spreadsheet and last row in each column. Iterates back from the last row in each column and deletes all empty cells shifting the filled cells up.

Sub DeleteAllAtOnce()
Application.ScreenUpdating = False
    Dim lastColumn As Long
    Dim lastRow As Long

    lastColumn = ActiveSheet.UsedRange.Columns.Count

    Dim i As Long, j As Long
    Dim cell As Range
    For i = lastColumn To 1 Step -1
        lastRow = Cells(rows.Count, i).End(xlUp).Row
        For j = lastRow To 1 Step -1
            Set cell = Cells(j, i)
            If IsEmpty(cell) Then cell.Delete shift:=xlUp
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub