Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 59509 Skopiuj do schowka Filtrowanie określonych wartości w tabeli przestawnej
Autor Wiadomość
cepats
Świeżak


Posty: 8
  Wysłany: 24-11-2017, 10:56   Filtrowanie określonych wartości w tabeli przestawnej

Witam serdecznie

Od jakiegoś czasu zastanawiam się nad problemem filtrowania za pomocą makra w tabeli przestawnej. Chcę utworzyć makro które po przypisaniu do przycisku w szybki sposób pokazywało by jasno określone parametry z danej kolumny tabeli (tak jak to się robi za pomocą filtru ręcznego).
Załączam plik z przykładową tabelą. Załóżmy że chcę z kolumny "Nazwa artykułu" ustawić filtr pokazujący trzy parametry: 493241, 479651 oraz 512116

Udało mi się zrobić to co zamierzam jednak po aktywacji makra filtrowanie trwało bardzo długo i zastanawiam się w jak najprostszy sposób można to osiągnąć bez zbędnego czekania.

Będę bardzo wdzięczny za pomoc
Pozdrawiam

problem.xlsx
Pobierz Plik ściągnięto 118 raz(y) 412.45 KB

ID posta: 334825 Skopiuj do schowka
 
 
cepats
Świeżak


Posty: 8
Wysłany: 24-11-2017, 13:36   

Dodam jeszcze że dokładnie to co chcę aby makro wykonało robi poniższe polecenie:

Kod:
Sub szukane()
Dim PI As PivotItem
With ActiveSheet.PivotTables("Tabela przestawna2").PivotFields("Numer artykulu")
.ClearAllFilters
For Each PI In .PivotItems
Select Case PI
    Case "512116", "512017": PI.Visible = True
    Case Else: PI.Visible = False
End Select
Next PI
End With
End Sub


Jednak tak jak wcześniej wspominałem trwa to bardzo długo.
Pozdrawiam
ID posta: 334842 Skopiuj do schowka
 
 
DwaNiedźwiedzie 
Excel Expert



Wersja: Win Office 2016
Pomógł: 278 razy
Posty: 686
Wysłany: 24-11-2017, 16:35   

Na początku kodu dopisz:
Kod:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.PivotTables("Tabela przestawna2").ManualUpdate = True

...a na końcu oczywiście przywróć pierwotne wartości - u mnie przeliczanie spadło z 20. do 6. sekund :)
ID posta: 334860 Skopiuj do schowka
 
 
kulasart
[Usunięty]

Wysłany: 24-11-2017, 18:21   

Jeżeli ma być naprawdę szybko to polecam coś takiego:
Kod:
Option Explicit


Sub szukaneFast()
    Dim pi As PivotItem
    Dim firstItem
    Dim fieldOrientation
   
    With Application
        .Application.ScreenUpdating = False
        .Application.Calculation = xlCalculationManual
    End With
   
    ActiveSheet.PivotTables("Tabela przestawna2").ManualUpdate = True
   
    With ActiveSheet.PivotTables("Tabela przestawna2").PivotFields("Numer artykulu")
        fieldOrientation = .Orientation
   
        For Each pi In .PivotItems
            If pi.RecordCount > 0 Then
                firstItem = pi.Value
                Exit For
            End If
        Next
   
   
        .ClearAllFilters
        .Orientation = xlPageField
        .EnableMultiplePageItems = False
        .CurrentPage = firstItem
   
   
        For Each pi In .PivotItems
            If pi.Value = "512116" Or pi.Value = "512017" Then
                pi.Visible = True
            End If
        Next pi
   
        .Orientation = fieldOrientation
   
        If firstItem <> "512116" And firstItem <> "512017" Then
            .PivotItems(firstItem).Visible = False
        End If
   
    End With
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
   
    MsgBox "end"
End Sub

Należy przy tym bardzo mocno podkreślić, że nie jest to rozwiązanie, które będzie błyskawiczne za każdym razem. Są pewne warunki, po spełnieniu których trzeba obrać trochę inny kierunek.
ID posta: 334865 Skopiuj do schowka
 
 
cepats
Świeżak


Posty: 8
Wysłany: 24-11-2017, 20:13   

DwaNiedźwiedzie napisał/a:
Na początku kodu dopisz:
Kod:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.PivotTables("Tabela przestawna2").ManualUpdate = True

...a na końcu oczywiście przywróć pierwotne wartości - u mnie przeliczanie spadło z 20. do 6. sekund :)


Dzięki to rzeczywiście przyspiesza nieco przeliczanie.

kulasart napisał/a:
Kod:
Option Explicit


Sub szukaneFast()
    Dim pi As PivotItem
    Dim firstItem
    Dim fieldOrientation
   
    With Application
        .Application.ScreenUpdating = False
        .Application.Calculation = xlCalculationManual
    End With
   
    ActiveSheet.PivotTables("Tabela przestawna2").ManualUpdate = True
   
    With ActiveSheet.PivotTables("Tabela przestawna2").PivotFields("Numer artykulu")
        fieldOrientation = .Orientation
   
        For Each pi In .PivotItems
            If pi.RecordCount > 0 Then
                firstItem = pi.Value
                Exit For
            End If
        Next
   
   
        .ClearAllFilters
        .Orientation = xlPageField
        .EnableMultiplePageItems = False
        .CurrentPage = firstItem
   
   
        For Each pi In .PivotItems
            If pi.Value = "512116" Or pi.Value = "512017" Then
                pi.Visible = True
            End If
        Next pi
   
        .Orientation = fieldOrientation
   
        If firstItem <> "512116" And firstItem <> "512017" Then
            .PivotItems(firstItem).Visible = False
        End If
   
    End With
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
   
    MsgBox "end"
End Sub


Niestety moja wiedza o Excelu na tym etapie się kończy. Niestety jak wklejam ten kod to makro zakrywa wszystkie pola, nie wiem może coś źle robię podczas wklejania. Mógłbym prosić abyś przesłał plik z zaimplementowanym i działającym makro z powyższym kodem?

Ma ktoś może jeszcze jakieś inne "prostsze" propozycję? :)

Pozdrawiam
ID posta: 334877 Skopiuj do schowka
 
 
kulasart
[Usunięty]

Wysłany: 24-11-2017, 20:22   

1) Otwierasz plik jaki załączyłeś do pierwszego posta.
2) Przechodzisz do edytora VBA (np. poprzez wciśnięcie ALT+F11)
3) Dodajesz nowy moduł (Menu "Insert", "Module")
4) W nowym module wstawiasz kod jaki podałem
5) Uruchamiasz
ID posta: 334880 Skopiuj do schowka
 
 
kulasart
[Usunięty]

Wysłany: 24-11-2017, 22:13   

OK, zapomnij o moim rozwiązaniu - wygląda na to że faktycznie nie działa.
ID posta: 334883 Skopiuj do schowka
 
 
cepats
Świeżak


Posty: 8
Wysłany: 25-11-2017, 12:13   

kulasart napisał/a:
1) Otwierasz plik jaki załączyłeś do pierwszego posta.
2) Przechodzisz do edytora VBA (np. poprzez wciśnięcie ALT+F11)
3) Dodajesz nowy moduł (Menu "Insert", "Module")
4) W nowym module wstawiasz kod jaki podałem
5) Uruchamiasz


Pisząc że moja wiedza o Excelu się kończy miałem na myśli zasadę działania kodu, na szczęście to jak to uruchomić mniej więcej ogarniam :)

Czy ktoś może zaproponować jeszcze jakieś inne rozwiązanie które sprawiło by że efekt działania kodu był by niemal natychmiastowy tak jak by się to robiło za pomocą ręcznego filtru?

Pozdrawiam
ID posta: 334907 Skopiuj do schowka
 
 
Cezary Czajka 
Excel Expert


Wersja: Win Office 2019
Pomógł: 145 razy
Posty: 696
Wysłany: 25-11-2017, 15:03   

Może tak. Wklej to, co ma być filtrowane o odśwież wszystko

problem.xlsx
Pobierz Plik ściągnięto 100 raz(y) 397.72 KB

_________________
W sumie - jest git
ID posta: 334920 Skopiuj do schowka
 
 
cepats
Świeżak


Posty: 8
Wysłany: 30-11-2017, 09:56   

Dziękuję wszystkim za pomoc. Okazało się ze poniższy kod działa dla mnie wystarczająco szybko i robi robotę :->

Kod:
Sub szukane()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("_SUROWCE_").PivotTables("Tabela przestawna2").ManualUpdate = True
Dim pi As PivotItem
With Sheets("_SUROWCE_").PivotTables("Tabela przestawna2").PivotFields("Numer artykulu")
.ClearAllFilters
For Each pi In .PivotItems
Select Case pi
    Case "512116", "512017", "552000", "563041": pi.Visible = True
    Case Else: pi.Visible = False
End Select
Next pi
End With
Application.ScreenUpdating = True
Sheets("_SUROWCE_").PivotTables("Tabela przestawna2").ManualUpdate = False
Sheets("_SUROWCE_").Select

End Sub


Niestety pojawił się kolejny mały problem. Generalnie dane z tej tabeli są zaciągane z systemu magazynowego i przedstawiają aktualne stany magazynowe. Filtrowane przedmioty o numerach np "512116" przedstawiają jeden ze składników wyrobu gotowego.

Kod:
 Case "512116", "512017", "552000", "563041": pi.Visible = True


Dla łatwiejszego planowania chcę aby z setek numerów po aktywacji konkretnego makro filtr pokazywał tylko części składowe jednego produktu. Niestety w momencie kiedy dany numer magazynowy np "512116" aktualnie jest pusty i nie ma go w tabeli przestawnej to po włączeniu makra wyskakuje błąd run-time error 1004 - ustawienie Visible klasy Pivotitem nie jest możliwe. Jest to w pełni logiczne bo jak ma coś widoczne skoro w danym momencie nie istnieje :)

Czy ma ktoś pomysł w jaki sposób zastosować jakiś warunek aby w tym przypadku makro pokazywało prawidłowo wszystkie aktualnie dostępne przedmioty z pominięciem tego pustego artykułu? Będę bardzo wdzięczny za pomoc.

Pozdrawiam
ID posta: 335239 Skopiuj do schowka
 
 
BluEEyE
Świeżak


Wersja: Win Office 365
Posty: 5
Wysłany: 15-02-2021, 11:53   

Witam,

Nie chcę zakładać nowego wątku, a spotkałem się dokładnie z takim samym problem. Mam zmienną "FS", którą szukam w filtrze. Problem jest taki, że nie w każdym tygodniu ten produkt jest produkowany. Jeśli jest produkowany to poniższy kod działa prawidłowo.

Kod:
Sub GS_weekly()
'
' GS_weekly Makro
'
' Klawisz skrótu: Ctrl+n
'

Dim week As String
Dim FS As String
Dim cost As String



week = Application.InputBox("Podaj numer tygodnia folderu, z którego danych chcesz skorzystać ?")

If TypeName(week) = "Boolean" Then Exit Sub
On Error Resume Next

FS = Application.InputBox("Podaj nr FS, dla którego dane wyciągnę ?")
If TypeName(FS) = "Boolean" Then Exit Sub
On Error Resume Next

cost = Application.InputBox("Podaj kolumnę, w której umieścić dane ?")
If TypeName(cost) = "Boolean" Then Exit Sub
On Error Resume Next

Windows("QR4 WK" & week & ".xlsx").Activate

Sheets("Arkusz3").Activate

With ActiveSheet.PivotTables("Tabela_przestawna_QR4_3").PivotFields("fin_style_id")
    .ClearAllFilters

        For Each PI In .PivotItems
            Select Case PI
            Case "" & FS & "": PI.Visible = True
            Case Else: PI.Visible = False
        End Select
        If PI.Name = "(blank)" Then Exit For
        Next PI
    End With

Windows("Bierun Lamination WK" & week & " 2021.xlsm").Activate

Sheets("" & FS & "").Activate

    Range("AI3").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(VLOOKUP(RC[-20],'[QR4 WK" & week & ".xlsx]Arkusz3'!R8C1:R72C2,2,FALSE),0)"
    Range("AI3").Select
    Selection.AutoFill Destination:=Range("AI3:AI12"), Type:=xlFillDefault
    Range("AI3:AI12").Select
    Selection.Copy
    Range("" & cost & "3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("AI15").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(VLOOKUP(R[-13]C[-33],'[LE WK" & week & ".xlsx]PV_value'!R4C1:R284C2,2,FALSE),0)"
    Range("AI15").Select
    Selection.Copy
    Range("" & cost & "15").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("AI").EntireColumn.Hidden = True
       
End Sub


Problem zaczyna się właśnie robić, gdy dana wartość zapisana jako zmienna "FS" nie jest widoczna filtrze więc wtedy makro zgodnie z kodem przeszukuje cały PivotFields("fin_style_id") i zaznacza ten ostatni widoczny, a następnie kopiuje z niego dane zamiast wpisywać zera.

W jaki sposób to rozwiązać, aby do pliku "Bierun Lamination WK" & week & " 2021.xlsm" były wpisywane same zera w odpowiednie komórki, jeśli makro nie znajdzie w PivotFields wartosći zapisanej pod zmienną "FS" ?

Dzięki wielkie za pomoc.
ID posta: 400425 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe