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

Jak propojit filtr kontingenční tabulky s určitou buňkou v aplikaci Excel?

Pokud chcete propojit filtr kontingenční tabulky s určitou buňkou a provést kontingenční tabulku filtrovanou na základě hodnoty buňky, může vám pomoci metoda v tomto článku.

Propojte filtr kontingenční tabulky s určitou buňkou pomocí kódu VBA


Propojte filtr kontingenční tabulky s určitou buňkou pomocí kódu VBA

Kontingenční tabulka, kterou propojíte její funkci filtru s hodnotou buňky, by měla obsahovat pole filtru (název pole filtru hraje důležitou roli v následujícím kódu VBA).

Jako příklad si vezměte níže uvedenou kontingenční tabulku, volá se pole filtru v kontingenční tabulce Kategorie, a obsahuje dvě hodnoty „výdaje"A"Prodej“. Po propojení filtru kontingenční tabulky s buňkou by hodnoty buňky, které použijete pro filtrování kontingenční tabulky, měly být „Výdaje“ a „Prodej“.

1. Vyberte buňku (zde vyberu buňku H6), kterou propojíte s funkcí filtru kontingenční tabulky, a do buňky předem zadejte jednu z hodnot filtru.

2. Otevřete list obsahující kontingenční tabulku, kterou propojíte s buňkou. Klikněte pravým tlačítkem na kartu listu a vyberte Zobrazit kód z kontextové nabídky. Viz snímek obrazovky:

3. V Microsoft Visual Basic pro aplikace zkopírujte níže uvedený kód VBA do okna Kód.

Kód VBA: Propojte filtr kontingenční tabulky s určitou buňkou

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

Poznámky:

1) "Sheet1„Je název otevřeného listu.
2) "Kontingenční tabulka 2„Je název kontingenční tabulky, kterou propojíte s funkcí filtru do buňky.
3) Filtrační pole v kontingenční tabulce se nazývá „Kategorie".
4) Odkazovaná buňka je H6. Tyto hodnoty proměnných můžete změnit podle svých potřeb.

4. zmáčkni Další + Q klávesy pro zavření Microsoft Visual Basic pro aplikace okno.

Nyní je funkce filtru kontingenční tabulky propojena s buňkou H6.

Obnovte buňku H6, poté se odpovídající data v kontingenční tabulce odfiltrují na základě existující hodnoty. Viz screenshot:

Při změně hodnoty buňky se filtrovaná data v kontingenční tabulce automaticky změní. Viz screenshot:


Snadno vyberte celé řádky na základě hodnoty buňky ve sloupci Certian:

Projekt Vyberte konkrétní buňky užitečnost Kutools pro Excel vám pomůže rychle vybrat celé řádky na základě hodnoty buňky ve sloupci certian v aplikaci Excel, jak je uvedeno níže. Po výběru všech řádků na základě hodnoty buňky je můžete ručně přesunout nebo zkopírovat do nového umístění podle potřeby v aplikaci Excel.
Stáhněte si a vyzkoušejte hned! (30denní trasa zdarma)


Související články:


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2019 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Kompletní funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50% a omezuje stovky kliknutí myší každý den!
officetab dno
Komentáře (32)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
jak to udělat na vícenásobném poli, protože v kódu je pouze jeden cíl
Tento komentář byl moderátorem webu minimalizován
Hi Frank
Sory ti s tím nepomůže.
Tento komentář byl moderátorem webu minimalizován
Co když je buňka propojená s kontingenční tabulkou, v tomto případě H6, na jiném listu? Jak to změní kód?
Tento komentář byl moderátorem webu minimalizován
co když mám více než 1 kontingenční tabulku a odkazuji na 1 buňku. Jak změním kód?
Tento komentář byl moderátorem webu minimalizován
Ahoj Jeri,
S tím vám bohužel nepomůžu. Vítejte, pokud chcete na našem fóru zveřejnit jakýkoli dotaz: https://www.extendoffice.com/forum.html získat další podporu Excelu od profesionála Excelu nebo jiných fanoušků Excelu.
Tento komentář byl moderátorem webu minimalizován
najděte je a změňte je v Array(),Intersect(), Worksheets(), PivotFields()

Kontingenční tabulka 1
Kontingenční tabulka 2
Kontingenční tabulka 3
Kontingenční tabulka 4
H1
Název listu
Název pole




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
Tento komentář byl moderátorem webu minimalizován
Boa tarde...! Ótima publicação, como faço para utilizar o filtro em duas ou mais tabelas dinâmicas...? Agradeço desde já.

Dobré odpoledne...! Skvělé publikování, jak mohu použít filtr ve dvou nebo více kontingenčních tabulkách ...? Díky předem.
Tento komentář byl moderátorem webu minimalizován
Ahoj Gilmare Alvesi,
S tím vám bohužel nepomůžu. Vítejte, pokud chcete na našem fóru zveřejnit jakýkoli dotaz: https://www.extendoffice.com/forum.html získat další podporu Excelu od profesionála Excelu nebo jiných fanoušků Excelu.
Tento komentář byl moderátorem webu minimalizován
Přišel někdo na otázku propojení více kontingenčních tabulek?
Tento komentář byl moderátorem webu minimalizován
Změňte hodnoty v Array(), Worksheets() a Intersect()



**Najděte tyto a změňte to**
Název listu
E1
Kontingenční tabulka 1
Kontingenční tabulka 2
Kontingenční tabulka 3




Soukromá dílčí tabulka_Změna (ByVal Target As Range)
'Aktualizovat od Extendoffice 20180702
Dim xPTable jako kontingenční tabulka
Dim xPFile As PivotField

Dim xPTabled As PivotTable
Dim xPFiled As PivotField

Dim xStr jako řetězec



On Error Resume Next

'리스트 만들기
Dim listArray() jako varianta
listArray = Array("PivotTable1", "PivotTable2", "PivotTable3")



If Intersect(Target, Range("E1")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False

Pro i = 0 To UBound(listArray)

Set xPTable = Worksheets("SheetName").PivotTables(listArray(i))
Nastavit xPFile = xPTable.PivotFields("ID_společnosti")

xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr



další

Application.ScreenUpdating = True



End Sub
Tento komentář byl moderátorem webu minimalizován
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.

Jaké jsou vlastnosti manca nella descrizione sopra?
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Zobrazila se vám nějaká chybová zpráva? Potřebuji vědět konkrétněji o vašem problému, jako je vaše verze Excelu. A pokud vám to nevadí, zkuste vytvořit svá data v novém sešitu a zkuste to znovu, nebo si udělejte snímek obrazovky a nahrajte je sem.
Tento komentář byl moderátorem webu minimalizován
Dobrý den,

Snažili jsme se, aby to fungovalo pro sloupcový filtr, ale zdá se, že to nefunguje. Potřebuji k tomu jiný kód?

Díky
Tento komentář byl moderátorem webu minimalizován
Ahoj Justin,
Zobrazila se vám nějaká chybová zpráva? Potřebuji vědět konkrétněji o vašem problému.
Před použitím kódu nezapomeňte upravit „název listu""název kontingenční tabulky""název filtru kontingenční tabulky"a buňka podle kterého chcete filtrovat kontingenční tabulku (viz snímek obrazovky).
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/4.png
Tento komentář byl moderátorem webu minimalizován
Ahoj Crystal,

Díky za vaši pomoc. Problém je, že funkce z nějakého důvodu nic nedělá. Nějaké upřesnění:

Název pivotu: Order_Comp_B2C
Název listu: Výpočtový list
Název filtru: Číslo týdne (tento název jsem změnil z toho, co bylo „Č. týdne odeslání“ v datovém souboru)
Buňka ke změně: O26 a O27 (to by mělo být v dosahu)

V tomto pivotu se snažím změnit filtr pro sloupce, v oblasti filtru v nabídce Pole kontingenční tabulky nic nemám.

můj kód je:

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
'Aktualizovat od Extendoffice 20180702
Dim xPTable jako kontingenční tabulka
Dim xPFile As PivotField
Dim xStr jako řetězec
On Error Resume Next
If Intersect(Target, Range("O26")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Calculation Sheet").PivotTables("Order_Comp_B2C")
Nastavit xPFile = xPTable.PivotFields("Číslo týdne")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End Sub

Díky,

Justin
Tento komentář byl moderátorem webu minimalizován
Ahoj Justine Teeuw,
Změnil jsem to Kontingenční název, název listu, název filtru a buňka změnit na podmínky, které jste uvedli výše, a vyzkoušeli jste kód VBA, který jste poskytli, v mém případě to funguje dobře. Viz následující GIF nebo přiložený sešit.
Nevadí vám vytvořit nový sešit a zkusit kód znovu?
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/6.gif
Tento komentář byl moderátorem webu minimalizován
Ahoj Crystal,

Připojený snímek obrazovky pivotu, červené pole je filtr, který bych chtěl změnit na základě hodnoty buňky.

Přednostně bych chtěl použít rozsah buněk označující více čísel týdnů.

Díky,

Justin
Tento komentář byl moderátorem webu minimalizován
Ahoj Justin,
Omlouvám se, že jsem na stránce neviděl snímek obrazovky, který jste připojili. Možná je na stránce nějaká chyba.
Pokud stále potřebujete problém vyřešit, napište mi na zxm@addin99.com. Omluvám se za nepříjemnost.
Tento komentář byl moderátorem webu minimalizován
Ahoj Justine Teeuw,
Zkuste prosím následující kód VBA. Doufám, že pomůžu.

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
Tento komentář byl moderátorem webu minimalizován
Použil jsem to na normální excel a fungovalo to. Ale nemohl jsem to použít na pracovní listy olap. možná to budu muset trochu změnit?
Tento komentář byl moderátorem webu minimalizován
Ahoj maziaritib4 TIB,
Metoda je dostupná pouze pro Microsoft Excel. Omluvám se za nepříjemnost.
Tento komentář byl moderátorem webu minimalizován
Ahoj Justin,

To fungovalo perfektně, ale zajímalo by mě, zda lze toto pravidlo použít na více kontingenčních tabulek na stejném listu?

Díky,
James
Tento komentář byl moderátorem webu minimalizován
Ahoj James,

Ano, je to možné, kód, který jsem k tomu použil, je (4 pivoty a 2 odkazy na buňky):

Soukromá dílčí tabulka_Změna (ByVal Target As Range)
Dim I As Integer
Dim xFilterStr1, xFilterStr2, yFilterstr1, yfilterstr2 jako řetězec
On Error Resume Next
Pokud Intersect(Target, Range("O26:P27")) není nic, pak Exit Sub

xFilterStr1 = Range("O26").Hodnota
xFilterStr2 = Range("O27").Hodnota
yFilterstr1 = Rozsah("p26").Hodnota
yfilterstr2 = Rozsah("p27").Hodnota
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Číslo týdne"). _
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Číslo týdne"). _
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Číslo týdne"). _
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Číslo týdne"). _
ClearAllFilters

If xFilterStr1 = "" And xFilterStr2 = "" And yFilterstr1 = "" And yfilterstr2 = "" Pak Exit Sub
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Číslo týdne"). _
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Číslo týdne"). _
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Číslo týdne"). _
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Číslo týdne"). _
EnableMultiplePageItems = True

xCount = ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Číslo týdne").PivotItems.Count
xCount = ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Číslo týdne").PivotItems.Count
yCount = ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Číslo týdne").PivotItems.Count
yCount = ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Číslo týdne").PivotItems.Count

Pro I = 1 To xCount
Pokud jsem <> xFilterStr1 A já <> xFilterStr2 Pak
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Číslo týdne").PivotItems(I).Visible = False
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Číslo týdne").PivotItems(I).Visible = False
Jiný
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Číslo týdne").PivotItems(I).Visible = True
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Číslo týdne").PivotItems(I).Visible = True
End If
další

Pro I = 1 To yCount
Pokud jsem <> yFilterstr1 A já <> yfilterstr2 Pak
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Číslo týdne").PivotItems(I).Visible = False
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Číslo týdne").PivotItems(I).Visible = False
Jiný
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Číslo týdne").PivotItems(I).Visible = True
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Číslo týdne").PivotItems(I).Visible = True
End If
další

End Sub
Tento komentář byl moderátorem webu minimalizován
Změňte hodnoty v Array(), Worksheets() a Intersect()



**Najděte tyto a změňte to**
Název listu
E1
Kontingenční tabulka 1
Kontingenční tabulka 2
Kontingenční tabulka 3




Soukromá dílčí tabulka_Změna (ByVal Target As Range)
'Aktualizovat od Extendoffice 20180702
Dim xPTable jako kontingenční tabulka
Dim xPFile As PivotField

Dim xPTabled As PivotTable
Dim xPFiled As PivotField

Dim xStr jako řetězec



On Error Resume Next

'리스트 만들기
Dim listArray() jako varianta
listArray = Array("PivotTable1", "PivotTable2", "PivotTable3")



If Intersect(Target, Range("E1")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False

Pro i = 0 To UBound(listArray)

Set xPTable = Worksheets("SheetName").PivotTables(listArray(i))
Nastavit xPFile = xPTable.PivotFields("ID_společnosti")

xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr



další

Application.ScreenUpdating = True



End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj,

Kód mi funguje dobře. Nemohu však dosáhnout toho, aby kontingenční tabulka automaticky aktualizovala cíl filtru. Cílem je v mém případě vzorec [DATE(D18,S14,C18)]. Kód funguje pouze tehdy, když dvakrát kliknu na cílovou buňku a stisknu Enter.

Děkuji
Tento komentář byl moderátorem webu minimalizován
Ahoj,

Tento kód funguje perfektně. Nemohu však získat kód pro automatickou aktualizaci kontingenční tabulky. Cílová hodnota je pro mě vzorec (=DATUM(D18,..,..)), který se mění v závislosti na tom, co je zvoleno v D18. Aby se kontingenční tabulka aktualizovala, musím dvakrát kliknout na cílovou buňku a stisknout Enter. Dá se to nějak obejít?

Děkuji
Tento komentář byl moderátorem webu minimalizován
Ahoj ST,
Předpokládejme, že vaše cílová hodnota je v H6 a mění se v závislosti na hodnotě v D18. Filtrovat kontingenční tabulku na základě této cílové hodnoty. Pomoci může následující kód VBA. Zkuste to prosím.
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
Tento komentář byl moderátorem webu minimalizován
Ahoj Crysal,

Do kódu jsem přidal řádek: Dim xRg As Range

Kód automaticky neresetuje data při změně cíle. Mám soubor Excel replikující to, co se snažím udělat, ale nemohu na tento web přidávat přílohy. D3 (cíl = DATUM(A15,B15,C15)) má rovnici spojenou s A15, B15 a C15. Když se změní jakákoli hodnota na A15, B15 a C15, kontingenční tabulka se resetuje na žádný filtr. Mohl byste mi s tím pomoci?
Tento komentář byl moderátorem webu minimalizován
Ahoj ST,
Moc nerozumím, co tím myslíš. Ve vašem případě se k filtrování kontingenční tabulky použije hodnota cílové buňky D3. Vzorec v cílové buňce D3 odkazuje na hodnoty buněk A15, B15 a C15, které se budou měnit podle hodnot v referenčních buňkách. Když se změní jakákoli hodnota na A15, B15 a C15, kontingenční tabulka bude automaticky filtrována, pokud hodnota v cílové buňce splňuje podmínky filtru kontingenční tabulky. Pokud hodnota v cílové buňce nesplňuje kritéria filtrování kontingenční tabulky, bude kontingenční tabulka automaticky resetována na žádné filtrování.
Tento komentář byl moderátorem webu minimalizován
Nejsem si jistý, zda existuje způsob, jak s vámi sdílet soubor aplikace Excel. Pokud se moje cílová hodnota, což je datum, změní podle změn v jiných buňkách. Musím dvakrát kliknout na cílovou buňku a stisknout Enter (jako byste to udělali po zadání vzorce do buňky), abych aktualizoval kontingenční tabulku
Tento komentář byl moderátorem webu minimalizován
Ahoj Sagar T,
Kód byl aktualizován. Zkuste to prosím. Děkujeme za vaši odezvu.
Nezapomeňte v kódu změnit názvy listu, kontingenční tabulky a filtru. Nebo si můžete stáhnout následující nahraný sešit pro testování.

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
Tento komentář byl moderátorem webu minimalizován
najděte je a změňte je v Array(),Intersect(), Worksheets(), PivotFields()

Kontingenční tabulka 1
Kontingenční tabulka 2
Kontingenční tabulka 3
Kontingenční tabulka 4
H1
Název listu
Název pole




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
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění