Açılır Liste ve Satır ve Sütun Filtreleme

[hedjaz]

Merhaba,

dosya üzerinde açıklamaya çalıştım. Umarım açıklayıcı olmuştur. Yardımcı olursanız sevinirim. Varsa başka bir yol ona da açığım.
Şimdiden desteğiniz için teşekkürler.

 

[Trilenium]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsKapak As Worksheet
Dim wsDenetim As Worksheet
Dim selectedDept As String
Dim deptColumns As Range
Dim cell As Range
Dim found As Range

Set wsKapak = ThisWorkbook.Sheets("Kapak")
Set wsDenetim = ThisWorkbook.Sheets("Denetim Listesi")

' E4 hücresindeki değişiklikleri kontrol et
If Not Intersect(Target, wsKapak.Range("E4")) Is Nothing Then
Application.ScreenUpdating = False

' Seçilen departmanı al
selectedDept = wsKapak.Range("E4").Value

' Denetim sayfasındaki departman başlıklarının aralığını tanımla
Set deptColumns = wsDenetim.Range("D1:M1")

' Departman başlıkları arasında seçilen departmanı bul
For Each cell In deptColumns
If cell.Value = selectedDept Then
Set found = cell
Exit For
End If
Next cell

' Departman bulunduysa diğer kolonları gizle ve siyah hücreleri filtrele
If Not found Is Nothing Then
' Tüm kolonları gizle
wsDenetim.Columns("D:M").Hidden = True

' Seçilen departman kolonunu göster
found.EntireColumn.Hidden = False

' Siyah hücreleri filtrele
With wsDenetim
.AutoFilterMode = False
found.AutoFilter Field:=found.Column, Criteria1:=RGB(0, 0, 0), Operator:=xlFilterCellColor
End With
End If

Application.ScreenUpdating = True
End If
End Sub



Kodu Kapak sayfasına yapıştırın.

 

[hedjaz]

Desteğiniz için çok teşekkür ederim. Elinize sağlık.