Ignore blank cells while copying and pasting macro

**dagindi** · 04-06-2011, 04:47 PM

attached is a sample worksheet.

The red bordered box shows how data appears in a spreadsheet.

I use the following macro to copy the data in the boxed range to a new workbook.

Sub Macro1()

    Application.Goto Reference:="New_Range2"
    Selection.SpecialCells(xlCellTypeVisible).Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=True, Transpose:=False
    Application.CutCopyMode = False
End Sub

I cannot figure out how to get the data to look like how I have it in the green bordered box.

**Leith Ross** · 04-07-2011, 01:50 AM

Hello dagindi,

You will need to change the destination range in this macro to the new workbook. I used Sheet2 "A1" as the destination to test the macro below.

Sub CopyAmdPaste()

  Dim C As Long
  Dim Col As Object
  Dim DstRng As Range
  Dim R As Long
  Dim RngRow As Range
  Dim SrcRng As Range
  
    Set SrcRng = Worksheets("Sheet1").Range("New_Range2")
    Set DstRng = Worksheets("Sheet2").Range("A1")
    
    Application.ScreenUpdating = False
    
     'Copy all non empty rows to the destination range
      For Each RngRow In SrcRng.Rows
        If WorksheetFunction.CountA(RngRow) <> 0 Then
           RngRow.Copy DstRng.Offset(R, 0)
           R = R + 1
        End If
      Next RngRow
      
      Set DstRng = DstRng.Resize(R, SrcRng.Columns.Count)
      
       'Remove all empty columns except "B"
        For C = DstRng.Columns.Count To 3 Step -1
          Set Col = DstRng.Columns(C)
          If WorksheetFunction.CountA(Col.Cells) = 0 Then
             Col.EntireColumn.Delete
          End If
        Next C
        
    Application.ScreenUpdating = True
    
End Sub