Note: The other languages of the website are Google-translated. Back to English

如何将数据透视表过滤器链接到Excel中的某个单元格?

如果要将数据透视表筛选器链接到某个单元格,并根据该单元格值对数据透视表进行筛选,则本文中的方法可以为您提供帮助。

使用VBA代码将数据透视表过滤器链接到特定单元格


使用VBA代码将数据透视表过滤器链接到特定单元格

您要将其筛选功能链接到数据透视表的数据透视表应包含一个筛选字段(筛选字段的名称在以下VBA代码中起着重要作用)。

以下面的数据透视表为例,数据透视表中的过滤器字段称为 类别,其中包括两个值“开支“和”销售”。 将数据透视表筛选器链接到一个单元格后,将应用于筛选数据透视表的单元格值应为“费用”和“销售”。

1.请选择一个单元格(在这里我选择单元格H6),您将链接到数据透视表的过滤器功能,并提前在该单元格中输入一个过滤器值。

2.打开包含要链接到单元格的数据透视表的工作表。 右键单击工作表标签,然后选择 查看代码 从上下文菜单中。 看截图:

3。 在里面 Microsoft Visual Basic应用程序 窗口,将下面的VBA代码复制到“代码”窗口中。

VBA代码:将数据透视表过滤器链接到某个单元格

Private Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180702
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xStr As String
    On Error Resume Next
    If Intersect(Target, Range("H6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Sheet1").PivotTables("PivotTable2")
    Set xPFile = xPTable.PivotFields("Category")
    xStr = Target.Text
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True
End Sub

说明:

1)“Sheet1”是打开的工作表的名称。
2)“数据透视表2”是数据透视表的名称,您会将其过滤功能链接到单元格。
3)数据透视表中的过滤字段称为“类别".
4)引用的单元格为H6。 您可以根据需要更改这些变量值。

4。 按 其他 + Q 关闭键 Microsoft Visual Basic应用程序 窗口。

现在,数据透视表的筛选功能已链接到单元格H6。

刷新单元格H6,然后根据现有值筛选出数据透视表中的相应数据。 看截图:

更改单元格值时,数据透视表中的筛选数据将自动更改。 看截图:


根据certian列中的单元格值轻松选择整个行:

新的 选择特定的单元格 实用程序 Kutools for Excel 可以帮助您根据Excel中的certian列中的单元格值快速选择整个行,如下图所示。 根据单元格值选择所有行后,可以根据需要在Excel中手动将其移动或复制到新位置。
立即下载并尝试! (30天免费试用)


相关文章:


最佳办公效率工具

Kutools for Excel解决了您的大多数问题,并使您的生产率提高了80%

  • 重用: 快速插入 复杂的公式,图表 以及您以前使用过的任何东西; 加密单元 带密码 创建邮件列表 并发送电子邮件...
  • 超级公式栏 (轻松编辑多行文本和公式); 阅读版式 (轻松读取和编辑大量单元格); 粘贴到过滤范围...
  • 合并单元格/行/列 不会丢失数据; 拆分单元格内容; 合并重复的行/列...防止细胞重复; 比较范围...
  • 选择重复或唯一 行; 选择空白行 (所有单元格都是空的); 超级查找和模糊查找 在许多工作簿中; 随机选择...
  • 确切的副本 多个单元格,无需更改公式参考; 自动创建参考 到多张纸; 插入项目符号,复选框等...
  • 提取文字,添加文本,按位置删除, 删除空间; 创建和打印分页小计; 在单元格内容和注释之间转换...
  • 超级滤镜 (将过滤方案保存并应用于其他工作表); 高级排序 按月/周/日,频率及更多; 特殊过滤器 用粗体,斜体...
  • 结合工作簿和工作表; 根据关键列合并表; 将数据分割成多个工作表; 批量转换xls,xlsx和PDF...
  • 超过300种强大功能。 支持Office / Excel 2007-2019和365。支持所有语言。 在您的企业或组织中轻松部署。 完整功能30天免费试用。 60天退款保证。
kte选项卡201905

Office选项卡为Office带来了选项卡式界面,使您的工作更加轻松

  • 在Word,Excel,PowerPoint中启用选项卡式编辑和阅读,发布者,Access,Visio和Project。
  • 在同一窗口的新选项卡中而不是在新窗口中打开并创建多个文档。
  • 每天将您的工作效率提高50%,并减少数百次鼠标单击!
officetab底部
按评论排序
注释 (32)
还没有评分。 成为第一位评论!
该评论由网站上的主持人最小化
如何在多个字段上执行此操作,因为在代码中只有一个目标
该评论由网站上的主持人最小化
嗨弗兰克
Sory 帮不了你。
该评论由网站上的主持人最小化
如果链接到数据透视表的单元格(在本例中为 H6)位于另一个工作表上怎么办? 它如何更改代码?
该评论由网站上的主持人最小化
如果我有超过 1 个数据透视表并链接到 1 个单元格怎么办。 我该如何修改代码?
该评论由网站上的主持人最小化
嗨,杰里,
抱歉不能帮你。 欢迎在我们的论坛发表任何问题: https://www.extendoffice.com/forum.html 从 Excel 专业人士或其他 Excel 粉丝那里获得更多 Excel 支持。
该评论由网站上的主持人最小化
找到这些并在 Array()、Intersect()、Worksheets()、Pivo​​tFields() 中进行更改

数据透视表1
数据透视表2
数据透视表3
数据透视表4
H1
工作表名称
字段名




Private Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180702
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xPTabled As PivotTable
    Dim xPFiled As PivotField
    Dim xStr As String
    On Error Resume Next
    '리스트 만들기
    Dim listArray() As Variant
    listArray = Array("PivotTable1", "PivotTable2", "PivotTable3", "PivotTable4")
    If Intersect(Target, Range("H1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For i = 0 To UBound(listArray)
        Set xPTable = Worksheets("SheetName").PivotTables(listArray(i))
        Set xPFile = xPTable.PivotFields("FieldName")
        'MsgBox (listArray(i))
        xStr = Target.Text
        xPFile.ClearAllFilters
        xPFile.CurrentPage = xStr
    Next
        Application.ScreenUpdating = True
End Sub
该评论由网站上的主持人最小化
迟到的蟒蛇……! Ótima publicação, como faço para utilizar o filtro em duas ou mais tabelas dinâmicas...? Agradeço desde já.

下午好...! 伟大的出版,我如何在两个或更多数据透视表中使用过滤器......? 提前致谢。
该评论由网站上的主持人最小化
嗨吉尔玛阿尔维斯,
抱歉不能帮你。 欢迎在我们的论坛发表任何问题: https://www.extendoffice.com/forum.html 从 Excel 专业人士或其他 Excel 粉丝那里获得更多 Excel 支持。
该评论由网站上的主持人最小化
有没有人想出多个数据透视表链接问题?
该评论由网站上的主持人最小化
更改 Array()、Worksheets() 和 Intersect() 中的值



**找到这些并更改它**
工作表名称
E1
数据透视表1
数据透视表2
数据透视表3




私人子Worksheet_Change(按目标的ByVal目标)
'更新者 Extendoffice 20180702
将 xPTable 调暗为数据透视表
将 xPFile 调暗为 PivotField

将 xPTabled 调暗为数据透视表
将 xP 归档为 PivotField

将 xStr 调暗为字符串



出错时继续下一步

'리스트 만들기
暗淡 listArray() 作为变体
listArray = Array("数据透视表1", "数据透视表2", "数据透视表3")



如果 Intersect(Target, Range("E1")) 什么都不是,则退出 Sub
Application.ScreenUpdating = False

For i = 0 To UBound(listArray)

设置 xPTable = Worksheets("SheetName").PivotTables(listArray(i))
设置 xPFile = xPTable.PivotFields("Company_ID")

xStr = 目标文本
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr



下一页

Application.ScreenUpdating =真



END SUB
该评论由网站上的主持人最小化
Ciao, sto provando a fare lo stesso esempio per far in modo che il filtro della pivot si setti sul valore della cella,
non riesco a farla funzionare。

Quale passaggio manca nella descrizione sopra?
该评论由网站上的主持人最小化
嗨,
你有没有得到任何错误提示? 我需要更具体地了解您的问题,例如您的 Excel 版本。 如果您不介意,请尝试在新工作簿中创建数据并再次尝试,或者截取数据并在此处上传。
该评论由网站上的主持人最小化
嗨,

试图让它适用于列过滤器,但似乎不起作用。 我需要其他代码吗?

谢谢
该评论由网站上的主持人最小化
嗨贾斯汀,
你有没有得到任何错误提示? 我需要更具体地了解您的问题。
在应用代码之前,不要忘记修改“工作表名称“”数据透视表的名称“”数据透视表的过滤器名称细胞 您想根据(见截图)过滤数据透视表。
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/4.png
该评论由网站上的主持人最小化
嗨水晶,

谢谢你的帮助。 问题是该功能由于某种原因没有做任何事情。 一些澄清:

数据透视名称:Order_Comp_B2C
表名称:计算表
过滤器名称:Week Number(我将这个名称从数据文件中的“Dispatch Week No”更改为)
要更改的单元格:O26 和 O27(这应该在范围内)

在此数据透视中,我试图更改列的过滤器,数据透视表字段菜单中的过滤器区域中没有任何内容。

我的代码是:

私人子Worksheet_Change(按目标的ByVal目标)
'更新者 Extendoffice 20180702
将 xPTable 调暗为数据透视表
将 xPFile 调暗为 PivotField
将 xStr 调暗为字符串
出错时继续下一步
如果 Intersect(Target, Range("O26")) 什么都不是,则退出 Sub
Application.ScreenUpdating = False
设置 xPTable = Worksheets("计算表").PivotTables("Order_Comp_B2C")
设置 xPFile = xPTable.PivotFields("周数")
xStr = 目标文本
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating =真
END SUB

谢谢,

贾斯汀
该评论由网站上的主持人最小化
嗨贾斯汀·蒂乌,
我已经改变了 枢轴名称, 工作表名称, 过滤器名称要改变的单元格 根据您上面提到的条件,并尝试了您提供的 VBA 代码,它在我的情况下运行良好。 请参阅以下 GIF 或随附的工作簿。
您介意创建一个新工作簿并再次尝试该代码吗?
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/6.gif
查看附件 (1 / 5)
该评论由网站上的主持人最小化
嗨水晶,

附上pivot的截图,红框是我想根据单元格值改变的过滤器。

最好我想使用一系列表示多个周数的单元格。

谢谢,

贾斯汀
该评论由网站上的主持人最小化
嗨贾斯汀,
抱歉,我没有看到您在页面上附加的屏幕截图。 也许页面上有一些错误。
如果您仍然需要解决问题,请通过 zxm@addin99.com 给我发送电子邮件。 带来不便敬请谅解。
该评论由网站上的主持人最小化
嗨贾斯汀·蒂乌,
请尝试以下 VBA 代码。 希望我能帮上忙。

Private Sub Worksheet_Change(ByVal Target As Range)
    'Update by Extendoffice 20220706
    Dim I As Integer
    Dim xFilterStr1, xFilterStr2 As String
    On Error Resume Next
    If Intersect(Target, Range("O26:O27")) Is Nothing Then Exit Sub
    'Application.ScreenUpdating = False
    
    xFilterStr1 = Range("O26").Value
    xFilterStr2 = Range("O27").Value
    ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number"). _
        ClearAllFilters
    If xFilterStr1 = "" And xFilterStr2 = "" Then Exit Sub
    ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number"). _
        EnableMultiplePageItems = True
    xCount = ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems.Count

    For I = 1 To xCount
        If I <> xFilterStr1 And I <> xFilterStr2 Then
            ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems(I).Visible = False
        Else
            ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems(I).Visible = True
        End If
    Next

    'Application.ScreenUpdating = True
End Sub
该评论由网站上的主持人最小化
我将它用于普通的 Excel 并且它有效。但我不能将它用于 olap 工作表。 也许我需要稍微改变一下?
该评论由网站上的主持人最小化
嗨 maziaritib4 TIB,
该方法仅适用于 Microsoft Excel。 带来不便敬请谅解。
该评论由网站上的主持人最小化
嗨贾斯汀,

这工作得很好,但是,我想知道这个规则是否可以应用于同一张表中的多个数据透视表?

谢谢,
JAMES
该评论由网站上的主持人最小化
嗨詹姆斯,

是的,这是可能的,我用于此的代码是(4 个枢轴和 2 个单元格引用):

私人子Worksheet_Change(按目标的ByVal目标)
将 I 调暗为整数
将 xFilterStr1、xFilterStr2、yFilterstr1、yfilterstr2 调暗为字符串
出错时继续下一步
如果 Intersect(Target, Range("O26:P27")) 什么都不是,则退出 Sub

xFilterStr1 = Range("O26").Value
xFilterStr2 = Range("O27").Value
yFilterstr1 = Range("p26").Value
yfilterstr2 = Range("p27").Value
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("周数")。 _
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("周数")。 _
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("周数")。 _
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("周数")。 _
清除所有过滤器

如果 xFilterStr1 = "" And xFilterStr2 = "" And yFilterstr1 = "" And yfilterstr2 = "" 然后退出 Sub
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("周数")。 _
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("周数")。 _
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("周数")。 _
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("周数")。 _
EnableMultiplePageItems = True

xCount = ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("周数").PivotItems.Count
xCount = ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("周数").PivotItems.Count
yCount = ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("周数").PivotItems.Count
yCount = ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("周数").PivotItems.Count

对于 I = 1 到 xCount
如果我 <> xFilterStr1 并且我 <> xFilterStr2 那么
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("周数").PivotItems(I).Visible = False
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("周数").PivotItems(I).Visible = False
其他
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("周数").PivotItems(I).Visible = True
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("周数").PivotItems(I).Visible = True
结束如果
下一页

对于 I = 1 到 yCount
如果我 <> yFilterstr1 并且我 <> yfilterstr2 那么
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("周数").PivotItems(I).Visible = False
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("周数").PivotItems(I).Visible = False
其他
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("周数").PivotItems(I).Visible = True
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("周数").PivotItems(I).Visible = True
结束如果
下一页

END SUB
该评论由网站上的主持人最小化
更改 Array()、Worksheets() 和 Intersect() 中的值



**找到这些并更改它**
工作表名称
E1
数据透视表1
数据透视表2
数据透视表3




私人子Worksheet_Change(按目标的ByVal目标)
'更新者 Extendoffice 20180702
将 xPTable 调暗为数据透视表
将 xPFile 调暗为 PivotField

将 xPTabled 调暗为数据透视表
将 xP 归档为 PivotField

将 xStr 调暗为字符串



出错时继续下一步

'리스트 만들기
暗淡 listArray() 作为变体
listArray = Array("数据透视表1", "数据透视表2", "数据透视表3")



如果 Intersect(Target, Range("E1")) 什么都不是,则退出 Sub
Application.ScreenUpdating = False

For i = 0 To UBound(listArray)

设置 xPTable = Worksheets("SheetName").PivotTables(listArray(i))
设置 xPFile = xPTable.PivotFields("Company_ID")

xStr = 目标文本
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr



下一页

Application.ScreenUpdating =真



END SUB
该评论由网站上的主持人最小化
你好,

该代码对我来说很好。 但是我无法让数据透视表自动更新过滤器目标。 在我的例子中,目标是一个公式 [DATE(D18,S14,C18)]。 该代码仅在我双击目标单元格并按 Enter 时才有效。

谢谢
该评论由网站上的主持人最小化
你好,

此代码完美运行。 但是我无法获取自动更新数据透视表的代码。 我的目标值是一个公式 (=DATE(D18,..,..)),它会根据在 D18 中选择的内容而变化。 为了更新数据透视表,我必须双击目标单元格并按 Enter。 有办法解决吗?

谢谢
该评论由网站上的主持人最小化
你好,
假设您的目标值在 H6 中,它会根据 D18 中的值而变化。 根据此目标值过滤数据透视表。 以下 VBA 代码可以提供帮助。 请试一试。
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2022/07/22
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim xBoolean As Boolean
Dim xItsRG As Range
Dim xDDs As Range
Dim xDs As Range
On Error Resume Next

xBoolean = False
Set xRg = Range("h6")

Set xItsRG = Intersect(Target, xRg)
Set xDDs = Intersect(Target.DirectDependents, xRg)
Set xDs = Intersect(Target.Dependents, xRg)
If Not (xItsRG Is Nothing) Then
    xBoolean = True
ElseIf Not (xDDs Is Nothing) Then
    xBoolean = True
ElseIf Not (xDs Is Nothing) Then
    xBoolean = True
End If


If Not xBoolean Then Exit Sub

Application.ScreenUpdating = False
Set xPTable = Worksheets("Sheet1").PivotTables("Pivot Table 1")
Set xPFile = xPTable.PivotFields("Category")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True

End Sub
该评论由网站上的主持人最小化
你好水晶,

我在代码上添加了一行:Dim xRg As Range

更改目标时,代码不会自动重置日期。 我有一个复制我想要做的事情的 excel 文件,但我无法在这个网站上添加附件。 D3 (target = DATE(A15,B15,C15)) 有一个与 A15、B15 和 C15 相关联的方程式。 当 A15、B15 和 C15 上的任何值更改时,数据透视表将重置为无过滤器。 你能帮我解决这个问题吗?
该评论由网站上的主持人最小化
嗨,ST,
我不太明白你的意思。 在您的情况下,目标单元格 D3 的值用于过滤数据透视表。 目标单元格 D3 中的公式引用了单元格 A15、B15 和 C15 的值,这些值将根据参考单元格中的值而变化。 当A15、B15、C15上的任意值发生变化时,如果目标单元格中​​的值满足数据透视表的过滤条件,数据透视表将被自动过滤。 如果目标单元格中​​的值不满足数据透视表的过滤条件,数据透视表将自动重置为不过滤。
该评论由网站上的主持人最小化
我不确定是否有办法与您共享 Excel 文件。 如果我的目标值(即日期)根据其他单元格的变化而变化。 我必须双击目标单元格并按回车键(就像在单元格中输入公式后一样)以更新数据透视表
该评论由网站上的主持人最小化
嗨,萨加尔 T,
代码已更新。 请试一试。 感谢您的反馈意见。
不要忘记在代码中更改工作表、数据透视表和过滤器的名称。 或者您可以下载以下上传的工作簿进行测试。

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220805
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim xBoolean As Boolean
Dim xItsRG As Range
Dim xDDs As Range
Dim xDs As Range
On Error Resume Next

xBoolean = False
Set xRg = Range("D3")

Set xItsRG = Intersect(Target, xRg)
Set xDDs = Intersect(Target.DirectDependents, xRg)
Set xDs = Intersect(Target.Dependents, xRg)
If Not (xItsRG Is Nothing) Then
    xBoolean = True
ElseIf Not (xDDs Is Nothing) Then
    xBoolean = True
ElseIf Not (xDs Is Nothing) Then
    xBoolean = True
End If


If Not xBoolean Then Exit Sub
xStr = Format(xRg.Text, "m/d/yyyy")
Application.ScreenUpdating = False
Set xPTable = Worksheets("Sheet2").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("Date")
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True

End Sub
查看附件 (1 / 5)
该评论由网站上的主持人最小化
找到这些并在 Array()、Intersect()、Worksheets()、Pivo​​tFields() 中进行更改

数据透视表1
数据透视表2
数据透视表3
数据透视表4
H1
工作表名称
字段名




Private Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180702
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xPTabled As PivotTable
    Dim xPFiled As PivotField
    Dim xStr As String
    On Error Resume Next
    '리스트 만들기
    Dim listArray() As Variant
    listArray = Array("PivotTable1", "PivotTable2", "PivotTable3", "PivotTable4")
    If Intersect(Target, Range("H1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For i = 0 To UBound(listArray)
        Set xPTable = Worksheets("SheetName").PivotTables(listArray(i))
        Set xPFile = xPTable.PivotFields("FieldName")
        'MsgBox (listArray(i))
        xStr = Target.Text
        xPFile.ClearAllFilters
        xPFile.CurrentPage = xStr
    Next
        Application.ScreenUpdating = True
End Sub
这里还没有评论
留下你的意见
以访客身份发帖
×
评价此帖子:
0   产品特性
建议地点