Makro ile tedarikçileri süzme işlemi

[neseterkutsesli]

Merhaba,
Tablo'da B sütununda koyu ve açık tedarikçilerin listesi var koyu kutucuğuna tıkladığımda B sütununda koyu tedarikçiler açık kutucuğuna tıkladığımda aynı şekilde B sütununda açık tedarikçileri süzmek istiyorum makro ile bunu yapabilirmiyiz
teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Sub Show_Bold_Cells()
    Dim Rng As Range, Bold_Rng As Range
    
    Application.ScreenUpdating = False
    
    Cells.EntireRow.Hidden = False
    
    For Each Rng In Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)
        If Rng.Font.Bold = False Then
            If Bold_Rng Is Nothing Then
                Set Bold_Rng = Rng
            Else
                Set Bold_Rng = Application.Union(Bold_Rng, Rng)
            End If
        End If
    Next
    
    If Not Bold_Rng Is Nothing Then
        Bold_Rng.EntireRow.Hidden = True
        Application.ScreenUpdating = True
        MsgBox "Yazı fontu koyu olanlar listelenmiştir."
    Else
        Application.ScreenUpdating = True
        MsgBox "Yazı fontu koyu olan hücre bulunamadı!"
    End If
End Sub

Sub Show_Not_Bold_Cells()
    Dim Rng As Range, Bold_Rng As Range
    
    Application.ScreenUpdating = False

    Cells.EntireRow.Hidden = False
    
    For Each Rng In Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)
        If Rng.Font.Bold = True Then
            If Bold_Rng Is Nothing Then
                Set Bold_Rng = Rng
            Else
                Set Bold_Rng = Application.Union(Bold_Rng, Rng)
            End If
        End If
    Next
    
    If Not Bold_Rng Is Nothing Then
        Bold_Rng.EntireRow.Hidden = True
        Application.ScreenUpdating = True
        MsgBox "Yazı fontu koyu olmayanlar listelenmiştir."
    Else
        Application.ScreenUpdating = True
        MsgBox "Yazı fontu koyu olmayan hücre bulunamadı!"
    End If
End Sub

 

[Korhan Ayhan]

Bu kod yapısı daha hızlı sonuç veriyor. İlk paylaştığım kod yapısı satır sayısı arttıkça yavaşlıyor.

Sub Show_Bold_Cells()
    Dim Ws As Worksheet
    Dim Rng As Range
    Dim Last_Row As Long
    Dim Hide_Address As String
    Dim Max_Len As Long
    Dim X As Double
    
    On Error GoTo Safe_Exit
    
    X = Timer
    
    Set Ws = ActiveSheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Last_Row = Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row
    Ws.Rows("2:" & Last_Row).Hidden = False
    
    Max_Len = 200
    
    For Each Rng In Ws.Range("B2:B" & Last_Row)
        If Rng.Font.Bold = False Then
            Hide_Address = Hide_Address & "," & Rng.EntireRow.Address
            If Len(Hide_Address) > Max_Len Then
                Ws.Range(Mid(Hide_Address, 2)).EntireRow.Hidden = True
                Hide_Address = ""
            End If
        End If
    Next Rng
    
    If Len(Hide_Address) > 0 Then
        Ws.Range(Mid(Hide_Address, 2)).EntireRow.Hidden = True
    End If
    
Safe_Exit:
    
    Set Ws = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    MsgBox "Yazı fontu koyu olanlar listelenmiştir." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - X, "0.00") & " Saniye"
End Sub

Sub Show_Not_Bold_Cells()
    Dim Ws As Worksheet
    Dim Rng As Range
    Dim Last_Row As Long
    Dim Hide_Address As String
    Dim Max_Len As Long
    Dim X As Double
    
    On Error GoTo Safe_Exit
    
    X = Timer
    
    Set Ws = ActiveSheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Last_Row = Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row
    Ws.Rows("2:" & Last_Row).Hidden = False
    
    Max_Len = 200
    
    For Each Rng In Ws.Range("B2:B" & Last_Row)
        If Rng.Font.Bold = True Then
            Hide_Address = Hide_Address & "," & Rng.EntireRow.Address
            If Len(Hide_Address) > Max_Len Then
                Ws.Range(Mid(Hide_Address, 2)).EntireRow.Hidden = True
                Hide_Address = ""
            End If
        End If
    Next Rng
    
    If Len(Hide_Address) > 0 Then
        Ws.Range(Mid(Hide_Address, 2)).EntireRow.Hidden = True
    End If
    
Safe_Exit:
    
    Set Ws = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    MsgBox "Yazı fontu koyu olmayanlar listelenmiştir." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - X, "0.00") & " Saniye"
End Sub

 

[neseterkutsesli]

Korhan Hocam,
verdiğiniz kodlar ile liste sorunsuz çalıştı yalnız bir buton daha koymayı unutmuşum oda listenin tümü butonu rica etsem o kodu yazabilirmisiniz
teşekkür ederim

 

[Korhan Ayhan]

Deneyiniz.

Sub Show_All_Rows()
    On Error GoTo Safe_Exit

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Cells.EntireRow.Hidden = False

Safe_Exit:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

 

[neseterkutsesli]

Korhan Hocam,
verdiğiniz bilgilerle bir çok insana yardımınız dokunuyor minnettarım sağolun..