Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Filtrowanie 3 kryteria

stingtanner · Wysłany: 18-05-2021, 10:54 **Filtrowanie 3 kryteria**

Witajcie
Mam chyba nietypowy problem związany z filtrowaniem.
W załączniku jest małe makro:

Kod:

Sub doXLSX_filter()
Dim wb As Workbook, sh As Worksheet
Dim auf As String, pos As String, sap As Range
Dim lr As Long
Set wb = ThisWorkbook
Set sh = wb.Worksheets("Stückliste")
lr = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row

auf = Selection.Offset(, -2).Value
pos = Selection.Offset(, -1).Value
Set sap = ActiveCell

sh.Range("A2:AM" & lr).AutoFilter Field:=1, Criteria1:=auf
sh.Range("A2:AM" & lr).AutoFilter Field:=2, Criteria1:=pos

' With sh.AutoFilter.Range
' If IsEmpty(.Range("C2", Cells(Rows.Count, "C").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(2, 1).Value) Then
' MsgBox "Nie podales numeru SAP lub zdublowane zamowienie. Sprawdz."
' .Range("C2", Cells(Rows.Count, "C").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(2, 1).Select
' Exit Sub
' End If
' End With
'
'
' Call doXLSX
'
' sh.Range("A2:AM" & lr).AutoFilter Field:=1
' sh.Range("A2:AM" & lr).AutoFilter Field:=2
'
' sap.Select

End Sub

Klikam w numer 105, który jest w kolumnie C.
Numer ten jest za każdym razem inny / unikalny, ale numery w kol A i B mogą się powtarzać.

Makro aktualnie łapie kliknięta komórkę, następnie przypisuje 2 komórki obok do zmiennych.
Tymi zmiennymi filtruję kolumny A i B.
To działa dobrze, pod warunkiem, że nie powtarza mi się numer z kolumny A i B.

Chciał bym dołożyć teraz 3 opcję, aby stworzyć unikalny zakres, który kończy się na linii poziomej pod każdym zestawem numerów z kol A i B.
Zaznaczyłem kolorami zakresy jakie chciał bym osiągnąć po zastosowaniu filtrowania lub innej operacji.

Nie wiem czy można to osiągnąć jakimś filtrowaniem zaawansowanym, czy już muszą iść inne sprawdzania?
Kolumna C gdzie jest numer 105, czasami pod tym numerem jest pusto aż do kolejnego zakresu, a częściej z numerami K..

Wynikiem jest zapisanie tego zakresu jako nowego pliku, który składa się z 3 numerów, a w nim maja być tylko dane dotyczące tych numerów.
W tym przykładzie dany kolor to osobny plik.

PS.
Kolorem proszę się nie sugerować, to tylko zobrazowanie, w oryginale ich nie ma.

Filtrowanie_3_kryteria.xlsm

Pobierz Plik ściągnięto 58 raz(y) 23.2 KB

kuma · Wysłany: 19-05-2021, 11:25

Przyglądnij się takiemu rozwiązaniu.
Filtrowanie odbywa się w dodatkowym arkuszu 'tmp'. W nim dokonuje się filtrowanie, zostawiłem miejsce na Twoje dodatkowe działania, np.zapis do nowego skoroszytu, itp, itd.
Po zakończeniu działań arkusz ten jest usuwany.
Wstawiłem linię z komendą 'Stop', abyś mógł wypróbować i sprawdzić zanim arkusz zostanie usunięty.
Po upewnieniu się, że wszystko działa dobrze, usuń tę linię.
Jeśli wybór komórki będzie poza kol. C to nie będzie danych po odfiltrowaniu.
Nie należy wybierać, w kol. C, komórki z wartościami, np, 37bar, bo będą niewłaściwe dane do filtrowania.

Kod:

Sub doXLSX_filter_kuma()
Dim wb As Workbook, sh As Worksheet
Dim auf As String, pos As String
Dim lr As Long
Dim st As Range
Dim nxt As Range

Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set sh = wb.Worksheets("Stückliste")
lr = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row

Set st = sh.Columns(3).Find("bar", after:=Cells(Selection.Row, 3), lookat:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set nxt = Range(sh.Cells(st.Row + 1, st.Column), sh.Cells(lr, st.Column)).Find("bar", lookat:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
If nxt Is Nothing Then Set nxt = sh.Cells(lr + 1, st.Column)
On Error Resume Next
auf = Selection.Offset(, -2).Value
pos = Selection.Offset(, -1).Value

With wb
.Sheets.Add(after:=.Sheets(.Sheets.Count)).Name = "tmp"
sh.Range("A" & st.Row & ":AM" & nxt.Row - 1).Copy Sheets("tmp").[a2]
End With
With Sheets("tmp").[a1].CurrentRegion
sh.Rows(2).Copy .Parent.[a1]
.AutoFilter Field:=1, Criteria1:=auf
.AutoFilter Field:=2, Criteria1:=pos
Dim a
If .Columns(1).SpecialCells(xlVisible).Cells.Count = 1 Then
MsgBox "Nie ma danych po odfiltrowaniu"
GoTo end_
End If
'
'tutaj zrób co potrzebujesz
'
'
End With
Stop
end_:
Application.DisplayAlerts = False
Sheets("tmp").Delete
Application.DisplayAlerts = True
End Sub

stingtanner · Wysłany: 19-05-2021, 12:07

kuma,
Dziękuję za rozwiązanie.
Tego się obawiałem, że nie ma tutaj tak mocno rozwiniętego sposobu filtrowania i trzeba będzie mocno kombinować.
Twoje rozwiązanie oczywiście działa jak należy. Problem jednak w tym że chciałem uniknąć tworzenia dodatkowego arkusza, który jak widać rozwiązuje problem bardzo dobrze.
Troszkę kombinowałem i poszedłem w podobną stronę co ty, ale bez tworzenia nowego arkusza:

Kod:

Sub doXLSX_filter()
Dim wb As Workbook, sh As Worksheet
Dim auf As String, pos As String, sap As Range
Dim lr As Long, i As Long
Set wb = ThisWorkbook
Set sh = wb.Worksheets("Stückliste")
lr = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Dim r1 As Range, r2 As Range, r3 As Range

auf = Selection.Offset(, -2).Value
pos = Selection.Offset(, -1).Value
Set sap = ActiveCell

sh.Range("A2:AM" & lr).AutoFilter Field:=1, Criteria1:=auf
sh.Range("A2:AM" & lr).AutoFilter Field:=2, Criteria1:=pos

Set r1 = sap.Offset(-1, -2)

Do
i = i + 1
Loop Until sap.Offset(i).Value Like "*105*"
Set r2 = sap.Offset(i)
Set r3 = Range(r1, r2.Offset(-2, 14))

With sh.AutoFilter.Range
If IsEmpty(.Range("C2", Cells(Rows.Count, "C").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(2, 1).Value) Then
MsgBox "Nie podales numeru SAP lub zdublowane zamowienie. Sprawdz."
.Range("C2", Cells(Rows.Count, "C").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(2, 1).Select
Exit Sub
End If
End With

Call doXLSX

sh.Range("A2:AM" & lr).AutoFilter Field:=1
sh.Range("A2:AM" & lr).AutoFilter Field:=2

sap.Select
End Sub

Wyznaczam początek i koniec zakresu pętlą, pewnie rozwiązanie wolniejsze ale też działa.

Jednak nie jest to jeszcze rozwiązanie idealne.
Zobaczę które na dłuższą metę i wielkość danych okaże się wydajniejsze.

Artik · Wysłany: 20-05-2021, 14:29

Nie wiem, czy to się na coś przyda. Ale skoro zrobiłem...

Zadanie zrozumiałem tak, że chcesz aby w arkuszu Stückliste po filtrowaniu były widoczne tylko dane z wybranego zakresu. A tym wybranym zakresem jest obszar "okalający" liczbę "105*".

Jednak w końcu chyba się okazało, że nie chodzi Ci o wizualizację, a tylko o określenie zakresu "okalającego" by go skopiować do nowego skoroszytu.

stingtanner · Wysłany: 21-05-2021, 10:19

kuma, Artik,
Muszę przyznać, że po zastosowaniu obu kodów, do istniejących rozwiązań jeden i drugi świetnie się spisują.
Wyniki są poprawne, a czas wykonywania w obu przypadkach jest zadowalający.