Yardım Aktarma sonrası filtrenin kaldırılması

mert25 · Salı saat 11:16'de

Merhabalar,

Ekteki dosyamda Ana Sayfada Aktar butonuna tıkladığımda AL5:AM5 hücrelerindeki veriler aşağıdaki kod ile Basketbol sayfasında aktarılıyor. Aktarma sonrası Ana Sayfadaki filtrenin kaldırılmasını istiyorum. Yardımcı olacak ustalara şimdiden teşekkür ederim.

Kod:

Private Sub CommandButton3_Click()
    Dim wsAnaSayfa As Worksheet
    Dim wsBasketbol As Worksheet
    Dim rngAnaSayfa As Range
    Dim matchFound As Boolean
    Dim i As Long
    Dim matchedRow As Long

    Set wsAnaSayfa = ThisWorkbook.Sheets("Ana Sayfa")
    Set wsBasketbol = ThisWorkbook.Sheets("Basketbol")

    ' Ana Sayfa sayfasındaki veri aralığını belirle
    Set rngAnaSayfa = wsAnaSayfa.Range("B6:F6")

    Application.ScreenUpdating = False

    ' Her bir Ana Sayfa hücresi için Basketbol sayfasında eşleşen satırı bul ve Z:AE aralığındaki verileri yaz
    matchFound = False
    For i = 6 To wsBasketbol.Cells(wsBasketbol.Rows.Count, "B").End(xlUp).Row
        If wsAnaSayfa.Cells(6, 2).Value = wsBasketbol.Cells(i, 2).Value And _
           wsAnaSayfa.Cells(6, 3).Value = wsBasketbol.Cells(i, 3).Value And _
           wsAnaSayfa.Cells(6, 4).Value = wsBasketbol.Cells(i, 4).Value And _
           wsAnaSayfa.Cells(6, 5).Value = wsBasketbol.Cells(i, 5).Value And _
           wsAnaSayfa.Cells(6, 6).Value = wsBasketbol.Cells(i, 6).Value Then

            ' Eşleşen satır bulunduğunda verileri kopyala
            wsBasketbol.Range("Z" & i & ":AE" & i).Value = wsAnaSayfa.Range("AJ5:AO5").Value
            matchFound = True
            matchedRow = i ' Eşleşen satırın numarasını sakla
            Exit For
        End If
    Next i

    If Not matchFound Then
        ' Eşleşen satır bulunamadıysa, hata mesajı verebilirsiniz (isteğe bağlı)
         MsgBox "Eşleşen satır bulunamadı: " & wsAnaSayfa.Cells(6, 2).Value & ", " & wsAnaSayfa.Cells(6, 3).Value & ", " & wsAnaSayfa.Cells(6, 4).Value & ", " & wsAnaSayfa.Cells(6, 5).Value & ", " & wsAnaSayfa.Cells(6, 6).Value
    Else
        ' Eşleşen satır bulunduysa, imleci D sütunundaki hücreye yerleştir
        wsBasketbol.Activate ' Basketbol sayfasını aktif hale getir
        wsBasketbol.Cells(matchedRow, 4).Select
    End If

    Application.ScreenUpdating = True

End Sub

muygun · Çarşamba saat 08:35'de

Merhaba;

Sayfanın kod bölümüne;

Sub auto_filtre_aç()
Application.ScreenUpdating = False
On Error Resume Next
Set S2 = ThisWorkbook.Worksheets("Ana Sayfa")
S2.Range("$B$4:$I$56").AutoFilter Field:=1
S2.Range("$B$4:$I$56").AutoFilter Field:=2
S2.Range("$B$4:$I$56").AutoFilter Field:=3
S2.Range("$B$4:$I$56").AutoFilter Field:=4
S2.Range("$B$4:$I$56").AutoFilter Field:=5
S2.Range("$B$4:$I$56").AutoFilter Field:=6
S2.Range("$B$4:$I$56").AutoFilter Field:=7
S2.Range("$B$4:$I$56").AutoFilter Field:=8
S2.Range("A3").Select
End Sub

Kodlarını ekleyerek deneyin.
İyi çalışmalar.

mert25 · Çarşamba saat 11:46'de

Cevap için teşekkür ederim. Fakat ben eksik bilgi vermişim, kusura bakmayın, yukarıda verdiğim kodun içine eklenmesini istemiştim, yani iki farklı buton değil de tek butona tıkladığımda hem aktarma yapsın hem de filtreyi temizlesin.

muygun · Dün 08:43 da

Kendi kodlarınızın sonundaki;

Application.ScreenUpdating = True
satırının altına;
Call auto_filtre_aç
yazın.

mert25 · Dün 09:03 da

muygun' Alıntı:
Kendi kodlarınızın sonundaki;

Application.ScreenUpdating = True
satırının altına;
Call auto_filtre_aç
yazın.

Maalesef hata verdi, çalışmadı

Yardım Aktarma sonrası filtrenin kaldırılması

Daha fazla seçenek

mert25

Ekli dosyalar

muygun

mert25

muygun

mert25