• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

  • Merhaba,
    Forumumuz yeni bir sunucuya taşındı. Maalesef son 24 saatlik kayıtlar taşınamadı. Bu nedenle bir kaç mesajı göremeyebilirsiniz.

    Bilgilerinize

Makro ile tedarikçileri süzme işlemi

neseterkutsesli

Altın Üye
Katılım
12 Ağustos 2011
Mesajlar
402
Excel Vers. ve Dili
Microsoft Office 2019
Windows 11 Home Single Language
Altın Üyelik Bitiş Tarihi
05-01-2028
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.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,637
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

C++:
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,637
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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.

C++:
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

Altın Üye
Katılım
12 Ağustos 2011
Mesajlar
402
Excel Vers. ve Dili
Microsoft Office 2019
Windows 11 Home Single Language
Altın Üyelik Bitiş Tarihi
05-01-2028
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
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,637
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
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

Altın Üye
Katılım
12 Ağustos 2011
Mesajlar
402
Excel Vers. ve Dili
Microsoft Office 2019
Windows 11 Home Single Language
Altın Üyelik Bitiş Tarihi
05-01-2028
Korhan Hocam,
verdiğiniz bilgilerle bir çok insana yardımınız dokunuyor minnettarım sağolun..
 
Üst