Soru Girilen Veriye Göre Otomatik Satır Gizle/Göster

H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
441
Excel Vers. ve Dili
2010, Türkiye
Merhabalar; ekli dosyadaki kod ile Listbox1 de seçilen sayfadaki F10:F40 hücre aralığındaki boş satırlar makro ile gizleniyor. Benim yapmak istediğim ise Listbox de seçilen sayfa değil de Veri girişi sayfasında işlem yaptığım zaman istenilen sayfalarda ki veri olmayan satırların otomatik olarak gizlenmesi . Yani ekli kodun sayfanın herhangi bir yerinde işlem yaparsam otomatik devreye girmesidir. Listbox1 işlemi iptal olacak.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim t As Range
Deger = ListBox1.Value
If Deger = "OLUR" Or Deger = "GÖREVLENDİRME" Or Deger = "HARCIRAH" Or Deger = "B" Then
Sheets(Deger).Unprotect "123" ' şifre var ise şifrenizni buraya yazın
For Each t In Sheets(Deger).Range("F10:F40").Cells
If t.Value = "" Or t.Value = 0 Then
t.EntireRow.Hidden = True
Else: t.EntireRow.Hidden = False
End If
Next t
Sheets(Deger).Protect "123" ' ' şifre var ise şifrenizni buraya yazın
End If
 
End Sub

İndir Örnek (1)

Dosyayı indir Örnek (1)
dosya.co
 
Korhan Ayhan

Korhan Ayhan

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

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sh As Worksheet, Rng As Range, Blank_Cells As Range
 
    If Intersect(Target, Range("F10:F40")) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
 
    For Each Sh In Sheets(Array("HARCIRAH", "OLUR", "GÖREVLENDİRME"))
        Set Blank_Cells = Nothing
        Sh.Unprotect "123"
        Sh.Range("F10:F40").EntireRow.Hidden = False
        For Each Rng In Sh.Range("F10:F40")
            If Rng = "" Or Rng = 0 Then
                If Blank_Cells Is Nothing Then
                    Set Blank_Cells = Rng
                Else
                    Set Blank_Cells = Union(Blank_Cells, Rng)
                End If
            End If
        Next
        If Not Blank_Cells Is Nothing Then Blank_Cells.EntireRow.Hidden = True
        Sh.Protect "123"
    Next

    Application.ScreenUpdating = True
End Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
441
Excel Vers. ve Dili
2010, Türkiye
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sh As Worksheet, Rng As Range, Blank_Cells As Range

    If Intersect(Target, Range("F10:F40")) Is Nothing Then Exit Sub

    Application.ScreenUpdating = False

    For Each Sh In Sheets(Array("HARCIRAH", "OLUR", "GÖREVLENDİRME"))
        Set Blank_Cells = Nothing
        Sh.Unprotect "123"
        Sh.Range("F10:F40").EntireRow.Hidden = False
        For Each Rng In Sh.Range("F10:F40")
            If Rng = "" Or Rng = 0 Then
                If Blank_Cells Is Nothing Then
                    Set Blank_Cells = Rng
                Else
                    Set Blank_Cells = Union(Blank_Cells, Rng)
                End If
            End If
        Next
        If Not Blank_Cells Is Nothing Then Blank_Cells.EntireRow.Hidden = True
        Sh.Protect "123"
    Next

    Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Korhan bey çok teşekkür ederim. Ellerinize sağlık. Kod muhteşem çalışıyor
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
441
Excel Vers. ve Dili
2010, Türkiye
Korhan bey hocam. Aynı makro içerisinde olur sayfasını F15:F40 aralığıni girilen veriye göre satır gizleme gösterme şartı olabilir mi. Diğer tanımlı sayfalar aynı kalacak
 
Korhan Ayhan

Korhan Ayhan

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

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sh As Worksheet, My_Area As Range, Rng As Range, Blank_Cells As Range

    If Intersect(Target, Range("F10:F40")) Is Nothing Then Exit Sub

    Application.ScreenUpdating = False

    For Each Sh In Sheets(Array("HARCIRAH", "OLUR", "GÖREVLENDİRME"))
        Set Blank_Cells = Nothing
        Sh.Unprotect "123"
        Set My_Area = IIf(Sh.Name = "OLUR", Sh.Range("F15:F40"), Sh.Range("F10:F40"))
        My_Area.EntireRow.Hidden = False
        For Each Rng In My_Area
            If Rng = "" Or Rng = 0 Then
                If Blank_Cells Is Nothing Then
                    Set Blank_Cells = Rng
                Else
                    Set Blank_Cells = Union(Blank_Cells, Rng)
                End If
            End If
        Next
        If Not Blank_Cells Is Nothing Then Blank_Cells.EntireRow.Hidden = True
        Sh.Protect "123"
    Next

    Application.ScreenUpdating = True
End Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
441
Excel Vers. ve Dili
2010, Türkiye
Korhan hocam makronun sadece F10:F40 hücre aralığında çalışmasını sağlayabilir miyiz. Diğer hücrelerde otomatik çalışmasa iyi olur diye düşünüyorum.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,156
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Zaten öyle olması gerekiyor.. Aşağıdaki satır o kısıtlamayı yapması gerekiyor.

If Intersect(Target, Range("F10:F40")) Is Nothing Then Exit Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
441
Excel Vers. ve Dili
2010, Türkiye
Korhan hocam merhabalar; aşağıdaki kod sayfanın tümünde aktif olarak devreye giriyor. Acaba bu kodun sayfanın sadece J300:J500 hücrelerinde aktif olmasını nasıl sağlayabiliriz ?
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim sat As Long
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, S4 As Worksheet, S5 As Worksheet, S6 As Worksheet, S7 As Worksheet
On Error Resume Next
Set S1 = Worksheets("ONAY EVRAKI HAZIRLAMA GİRİŞİ")
Set S2 = Worksheets("PİYASA ARAŞTIRMA")
Set S3 = Worksheets("PİYASA ARAŞTIRMA TUTANAĞI")
Set S4 = Worksheets("TEKLİF DEĞERLENDİRME TUTANAĞI")
Set S5 = Worksheets("METRAJ CETVELİ")
Set S6 = Worksheets("YAKLAŞIK MALİYET CETVELİ")
Set S7 = Worksheets("SÖZLEŞME")
Set S8 = Worksheets("BİRİM FİYAT KARARI")
S2.Range("F300:H500") = S1.Range("F300:H500").Value
S2.Range("I300:I500") = S1.Range("J300:J500").Value
S3.Range("F300:G500") = S1.Range("F300:G500").Value
S3.Range("J300:J500") = S1.Range("L300:L500").Value
S3.Range("L300:L500") = S1.Range("N300:N500").Value
S3.Range("N300:N500") = S1.Range("P300:P500").Value
S4.Range("F300:H500") = S1.Range("F300:H500").Value
S4.Range("I300:I500") = S1.Range("J300:J500").Value
S4.Range("J300:K500") = S1.Range("L300:M500").Value
S4.Range("L300:Q500") = S1.Range("L300:Q500").Value
S5.Range("F300:H500") = S1.Range("F300:H500").Value
S5.Range("J300:J500") = S1.Range("J300:J500").Value
S5.Range("K300:K500") = S1.Range("I300:I500").Value
S5.Range("L300:L500") = S1.Range("K300:K500").Value
S6.Range("F300:H500") = S1.Range("F300:H500").Value
S6.Range("J300:J500") = S1.Range("J300:J500").Value
S6.Range("K300:K500") = S1.Range("I300:I500").Value
S6.Range("L300:L500") = S1.Range("K300:K500").Value
S7.Range("F300:H500") = S1.Range("F300:H500").Value
S7.Range("I300:I500") = S1.Range("J300:J500").Value
S7.Range("J300:J500") = S1.Range("L300:L500").Value
S7.Range("K300:K500") = S1.Range("M300:M500").Value
S8.Range("F300:H500") = S1.Range("F300:H500").Value
S8.Range("J300:J500") = S1.Range("J300:J500").Value
S8.Range("K300:K500") = S1.Range("I300:I500").Value
S8.Range("L300:L500") = S1.Range("K300:K500").Value
For Each Sayfa In Worksheets
        Select Case Sayfa.Name
            Case "ONAY EVRAKI HAZIRLAMA GİRİŞİ", "VAHİDİ FİYAT ONAY GİRİŞİ GİRİŞİ", "ÖDEME GİRİŞİ", "İLAN GİRİŞİ"
            Case S2.Name
                Sayfa.Rows("300:500").Hidden = False
                Sayfa.Range("F310:F500").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
            Case Else
                Sayfa.Rows("300:500").Hidden = False
                Sayfa.Range("F300:F500").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
        End Select
    Next
    Application.ScreenUpdating = True
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,156
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Aşağıdaki yöntemi kullanabilirsiniz.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("J300:J500")) Is Nothing Then Exit Sub
    Rem Kendi kodlarınızı bu bölüme yazınız...
End Sub
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
441
Excel Vers. ve Dili
2010, Türkiye
Korhan Ayhan' Alıntı:
Aşağıdaki yöntemi kullanabilirsiniz.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("J300:J500")) Is Nothing Then Exit Sub
    Rem Kendi kodlarınızı bu bölüme yazınız...
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst