Veri aktarma sonrası filtrenin kaldırılması

[mert25]

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. Aşağıdaki koda bir ekleme yapılarak aktarma sonrası Ana Sayfadaki filtrenin kaldırılmasını istiyorum. Yardımcı olacak ustalara şimdiden teşekkür ederim.

Kod: Tümünü seç

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

[SNNAY]

Deneyiniz

Kod: Tümünü seç

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

    ' Ana Sayfa sayfasındaki filtreyi kaldır
    If wsAnaSayfa.FilterMode Then
        wsAnaSayfa.ShowAllData
    End If

    Application.ScreenUpdating = True
End Sub