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: 68232 Skopiuj do schowka Filtrowanie tabeli przestawnej przez VBA
Autor Wiadomość
istasz
świeżak


Posty: 9
Wysłany: 27-05-2020, 09:53   Filtrowanie tabeli przestawnej przez VBA

Witajcie,

Z góry dziękuję jeżeli ktoś się nad tym pochyli.

W jednym arkuszu mam prostą tabelę przestawną z kolumnami:
Artykul, EAN, NrHandlowy
Do tego mam Arkusz1 z samymi kodami ean w pierwszej kolumnie.
I chcę w tabeli przestawnej przefiltrować wszystko tak aby pozostały tylko produkty z kodami EAN z Arkusza1.
Stworzyłem do tego makro i nawet działa (sprawdziłem na małej próbce). Ale problem jest w tym, że makro przechodzi każdy kod ean w tabeli przestawnej, a mam ich 10000. Wczoraj podjąłem próbę i przez 1,5 godziny nie skończyło filtrowania dwóch ean-ów z Arkusza1.
Czy znacie sposób aby to przyspieszyć? Myślałem może że mogę założyć filtry na innych kolumnach aby ograniczyć ilość EAN-ów w tabeli przestawnej ale ten kod i tak widzi wszystkie EAN-y nawet po ograniczaniu filtrem w innej kolumnie.
Kod VBA niżej i załączam przykładowy plik.


KOD VBA:
Kod:
Sub MakroI()
 
Dim oPvtItem As PivotItems
Dim iFltr As String
Dim CountRows As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Arkusz1")

Set oPvtItem = ActiveSheet.PivotTables("Tabela przestawna1").PivotFields("EAN").PivotItems
CountRows = ThisWorkbook.Sheets("Arkusz1").Cells(Rows.Count, 1).End(xlUp).Row
'MsgBox (CountRows)
For Each pvt In oPvtItem
    For i = 1 To CountRows
    iFltr = ActiveWorkbook.Worksheets("Arkusz1").Range("A" & i).Value
        If pvt.Name = iFltr Then
            pvt.Visible = True
            Exit For
        Else
            pvt.Visible = False
        End If
    Next i
Next
End Sub



Edit: Marecki
Przy wpisywaniu kodów makr lub formuł używaj znaczników [code] (zgodnie z pkt. 3.1 Regulaminu naszego forum).


Zeszyt1 (version 1).xlsm
Pobierz Plik ściągnięto 12 raz(y) 25.24 KB

_________________
Igor
ID posta: 387957 Skopiuj do schowka
 
 
DwaNiedźwiedzie 
Excel Expert



Wersja: Win Office 2010
Pomógł: 251 razy
Posty: 632
Wysłany: 27-05-2020, 17:21   

1) Wyłącz odświeżanie ekranu na czas filtrowania danych, już samo to znacznie przyspieszy działanie kodu.
2) Przepisz szukane wartości do zmiennej, każdorazowe odczytywanie ich z arkusza to kolejny poważny opóźniacz. W moim kodzie posłużyłem się słownikiem, bo to najprostsza metoda sprawdzenia, czy dana wartość jest na liście szukanych. Wykorzystałem też specyficzne zachowanie słownika - jeżeli próbujesz pobrać wartość z nieistniejącego elemetnu, to ten element zostaje utworzony ("sz = dict(sz)").
3) Przed ustawieniem widoczności elementu tabeli sprawdź, czy nie jest on już we właściwym stanie - odczytanie tej właściwości powinno być szybsze niż jej wymuszone ustawienie.
4) Zdaje się, że pivoty mają problemy z wersjami językowymi dla pustych rekordów (czyli naszymi "(puste)"), stąd "IsError".

Sprawdź coś takiego:
Kod:
Sub MakroII()
Dim oPvtItem As PivotItems, arr(), dict, pvt As PivotItem, a

Set oPvtItem = ThisWorkbook.Sheets("Arkusz2").PivotTables("Tabela przestawna1").PivotFields("EAN").PivotItems

With ThisWorkbook.Sheets("Arkusz1")
   szukane = Range(.[a1], .Cells(Rows.Count, 1).End(xlUp)).Value2
End With

Set dict = CreateObject("scripting.dictionary")

For Each sz In szukane
   sz = dict(sz)
Next

Application.ScreenUpdating = False

For Each pvt In oPvtItem
   If dict.exists(pvt.Name) Then
      If Not pvt.Visible Then pvt.Visible = True
   Else
      If IsError(pvt.SourceName) Then
         pvt.Visible = False
      ElseIf pvt.Visible Then
         pvt.Visible = False
      End If
   End If
Next

Application.ScreenUpdating = True

End Sub
ID posta: 387986 Skopiuj do schowka
 
 
istasz
świeżak


Posty: 9
Wysłany: 28-05-2020, 16:45   

Dziękuję za pomoc.
Twoja kod jest szybszy ale wciąż coś chyba jest nie tak po przerabia jakieś 9 ean-ów na minutę więc juz po 16 godzinach się zrobi.
Muszę coś innego znaleźć.
_________________
Igor
ID posta: 388058 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2385 razy
Posty: 7806
Wysłany: 28-05-2020, 21:19   

Zobacz tak:
Kod:
Sub MakroI()
    Dim pt               As PivotTable
    Dim pf               As PivotField
    Dim pi               As PivotItem
    Dim vArrSel          As Variant
    Dim vItem            As Variant

    On Error Resume Next

    With ThisWorkbook.Sheets("Arkusz1")
        vArrSel = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With

    Set pt = Sheets("Arkusz2").PivotTables("Tabela przestawna1")

    Set pf = pt.PivotFields("EAN")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    With pf
        For Each pi In pf.PivotItems
            pi.Visible = False
        Next pi
       
        For Each vItem In vArrSel
            .PivotItems(vItem).Visible = True
        Next vItem
        .PivotItems("(blank)").Visible = False
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 388071 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