Try this
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).pastespecial(xlpastevalues)
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
Bookmarks