Excel 2016 - VBA - 数据透视表 - 如果包含“（空白）”，则从复制行中排除

Question

注意：如果您个人对本文中的某些内容不清楚，建设性途径是询问您需要澄清的具体内容。

我有以下代码，它可以满足我的需要 - 它适用于活动工作表上唯一的数据透视表。这些数据透视表总是只有两列。选择不包括页眉/页脚，仅选择数据。复制第一列，将其粘贴到第二列的右侧。扩展选择以包括粘贴的数据和第二列 - 复制它。

问题：如果一行包含“（空白）”，如何排除复制

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

我建议不要逐行复制，而是过滤掉空白，然后将全部内容一次性复制到您需要的地方，这样会更容易、更有效。或者，如果要重新排列列的顺序，请逐列复制。

要查看过滤空白的代码，请参阅Pivot Field Show All Except Blank

Jon Peltier 在https://peltiertech.com/referencing-pivot-table-ranges-in-vba/ 上发表了一篇关于引用数据透视表范围的精彩帖子

Answer 2

添加了一些代码，如果它包含“空白”，则将选择的大小调整为短一行 - 这有效：

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

我很快就把它放在一起了。如果要检查多个列，则需要进行修改，但这应该可以帮助您开始。

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