Excel 2016 - VBA - Pivot Table - exclude from copying a row if it contains "(blank)" - excel

Question

NOTE: if you are personally unclear on something in this post, constructive route is to ask with specifics of what do you need clarification on.
I have following code, which does what I need - it works with the only pivot table on active worksheet. These pivot tables always have only two columns. Selection excludes header/footer, selects only data. Copies 1st column, pastes it to the right of the 2nd column. Expands selection to include pasted data and second column - copies that.
Issue: how to exclude from copying a row if it contains "(blank)"
Sub PivotPrep4POST()
'
' PivotPrep4POST Macro
'
Application.ScreenUpdating = False
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables(1)
Dim ws As Worksheet
'selects Row range of pivot
pt.RowRange.Select
'trims two last rows off selection
Selection.Resize(Selection.Rows.Count - 2, Selection.Columns.Count + 0).Select
'shifts selection one row down, resulting in selection minus top and bottom row
Selection.Offset(1, 0).Select
Selection.Copy
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Resize(Selection.Rows.Count - 0, Selection.Columns.Count + 1).Select
Selection.Offset(0, -1).Select
Selection.Copy
Application.ScreenUpdating = True
'
End Sub

Answer 1

Instead of copying row by row, I suggest it will be much easier and more efficient to filter out blanks, and copy the whole lot in one go to where you need it. Or if you want to rearrange the order of the columns, then copy it column by column.
To see code on filtering out blanks, see Pivot Field Show All Except Blank
Jon Peltier has a great post on referencing PivotTable Ranges at https://peltiertech.com/referencing-pivot-table-ranges-in-vba/

Answer 2

Added a bit of code that resizes selection one row short, if it contains "blank" - and this works:
Sub PivotPrep4POST2()
'
' PivotPrep4POST Macro
'
Application.ScreenUpdating = False
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables(1)
Dim ws As Worksheet
'selects Row range of pivot
pt.RowRange.Select
'trims two last rows off selection
Selection.Resize(Selection.Rows.Count - 2, Selection.Columns.Count + 0).Select
'shifts selection one row down, resulting in selection minus top and bottom row
Selection.Offset(1, 0).Select
Selection.Copy
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Resize(Selection.Rows.Count - 0, Selection.Columns.Count + 1).Select
Selection.Offset(0, -1).Select
'Added this
Dim SrchRng As Range, cel As Range
Set SrchRng = Selection
For Each cel In SrchRng
If InStr(1, cel.Value, "blank") > 0 Then
Selection.Resize(Selection.Rows.Count - 1, Selection.Columns.Count + 0).Select
End If
Next cel
'end of addition
Selection.Copy
Application.ScreenUpdating = True
'
End Sub

Answer 3

I threw this together real quick. If you want to check more than one column, you would need to modify, but this should get you started.
Sub PivotPrep4POST()
'
' PivotPrep4POST Macro
'
Application.ScreenUpdating = False
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables(1)
Dim ws As Worksheet
'selects Row range of pivot
pt.RowRange.Select
'trims two last rows off selection
Selection.Resize(Selection.Rows.Count - 2, Selection.Columns.Count + 0).Select
'shifts selection one row down, resulting in selection minus top and bottom row
Selection.Offset(1, 0).Select
Selection.Copy
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Resize(Selection.Rows.Count - 0, Selection.Columns.Count + 1).Select
Selection.Offset(0, -1).Select
'New Code (7/11/2018)
Dim rCell As Range, newRng As Range, tRng As Range
Set tRng = Selection
For Each rCell In tRng.Columns(1).Cells
If rCell.Value2 <> "(blank)" Then
If newRng Is Nothing Then
Set newRng = Intersect(rCell.EntireRow, tRng)
Else
Set newRng = Union(newRng, Intersect(rCell.EntireRow, tRng))
End If
End If
Next rCell
newRng.Select
'End new code
Selection.Copy
Application.ScreenUpdating = True
'
End Sub