Hücre gizleme Makrosu - belli bir satırdan sonrası

gurayavci · 30 Mart 2023

Merhaba,

Hücre satır sütun gizleme ile ilgili birçok konu gördüm fakat hepsi farklı içeriklere sahip, aradığım türde çözüm bulamadım

Ekli dosya üzerinde ;
EĞER h36 0 İSE D36-E36-F36-G36-H36-I36 GİZLENSİN FAKAT GİZLEME YAPILDIĞINDA 59. SATIRDAN AŞAĞISININ OYNAMAMASI GEREKİYOR, ÇÖZEMEDİM DESTEĞİNİZİ RİCA EDİYORUM
36 İLE 58. SATIR ARASINDAKİ TÜM SATIRLARDA BU GİZLEMEYE İHTİYACIM VAR

Amacım B36yı sabit tutup diğer hücreleri eğer adet ve kg sütununda veriler 0 ise gizlemek.

Teşekkürler

palhex · 30 Mart 2023

Dosyayı indiremiyorum...
Bir dosya paylaşım sitesine atma şansınız var mı?
Teşekkürler.

ridvanucok · 30 Mart 2023

Merhaba,

Aşağıdaki VBA kodunu kullanarak, H36 hücresindeki değer 0 olduğunda D36, E36, F36, G36, H36 ve I36 hücrelerinin gizlenmesi ve aynı zamanda 59. satırdan sonraki satırların korunması sağlanabilir.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$H$36" Then
If Target.Value = 0 Then
Rows("36:58").EntireRow.Hidden = True
Rows("59:" & Rows.Count).EntireRow.Locked = True
Else
Rows("36:58").EntireRow.Hidden = False
Rows("59:" & Rows.Count).EntireRow.Locked = False
End If
End If
End Sub

gurayavci · 31 Mart 2023

ridvanucok' Alıntı:
Merhaba,

Aşağıdaki VBA kodunu kullanarak, H36 hücresindeki değer 0 olduğunda D36, E36, F36, G36, H36 ve I36 hücrelerinin gizlenmesi ve aynı zamanda 59. satırdan sonraki satırların korunması sağlanabilir.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$H$36" Then
If Target.Value = 0 Then
Rows("36:58").EntireRow.Hidden = True
Rows("59:" & Rows.Count).EntireRow.Locked = True
Else
Rows("36:58").EntireRow.Hidden = False
Rows("59:" & Rows.Count).EntireRow.Locked = False
End If
End If
End Sub

Rıdvan Bey ilginize teşekkür ederim

Kod otomatik çalışmadı başka bir hatadan dolayı mı yada ben mi çalıştıramadım ?
Hiçbirşeye tıklamadan otomatik çalıştırmam gerekiyor kodu , yardımcı olabilirmisiniz?

Sayfanın kod alanına ekledim ama çalışmadı

gurayavci · 3 Nisan 2023

Merhaba,
Destek olabilecek kimse varmıdır ?

gurayavci · 5 Nisan 2023

kimse yok mu ?

Korhan Ayhan · 5 Nisan 2023

Merhaba,

Veriler formülle dış kaynaktan geldiği için dosya açılışında bu işlemi yapmanız daha uygun görünüyor.

Kodu ThisWorkbook bölümüne uygulayınız.

C++:

Option Explicit

Private Sub Workbook_Open()
    Dim Rng As Range, My_Area As Range
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Sheets("Konşimento_Talimatı").Rows("36:58").EntireRow.Hidden = False
   
    For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

gurayavci · 5 Nisan 2023

Korhan Ayhan' Alıntı:

Merhaba,

Veriler formülle dış kaynaktan geldiği için dosya açılışında bu işlemi yapmanız daha uygun görünüyor.

Kodu ThisWorkbook bölümüne uygulayınız.

C++:

Option Explicit

Private Sub Workbook_Open()
    Dim Rng As Range, My_Area As Range
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Sheets("Konsimento_Talimati").Rows("36:58").EntireRow.Hidden = False
   
    For Each Rng In Sheets("Konsimento_Talimati").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Korhan Bey teşekkür ederim

fakat aşağıdaki hatayı verdi, dosyaya kodu eklediğim halini de ekliyorum

Runtime - 9

Subscript out of range

Debug
"""
Sheets("Konsimento_Talimati").Rows("36:58").EntireRow.Hidden = False
"""

Korhan Ayhan · 5 Nisan 2023

Çok afedersiniz. Benim bilgisayarda Türkçe karakter sorunu yaşadığım için sayfa adını değiştirmiştim. Foruma kodu eklerken düzeltmeyi atlamışım.

Kodu revize ettim. Tekrar deneyiniz.

gurayavci · 7 Nisan 2023

Korhan Beyyyy , çok teşekkür ederim

Muhteşem ötesisiniz

Kodun aktif çalışması için şu an exceli kaydedip kapatıp açmam gerekiyor , bunun bir çözümü var mıdır ?
değişiklik yaptığımda excel açıkken güncellemiyor sayfayı şu an

Korhan Ayhan · 7 Nisan 2023

Önerdiğim kodu başlıklar hariç aradaki satırları aynı modüle aşağıdaki bloğa uygulayınız. Bu adımdan sonra her değişiklikte yeniden hesaplama yaptığında otomatik çalışması gerekir.

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)

gurayavci · 7 Nisan 2023

Korhan Ayhan' Alıntı:
Önerdiğim kodu başlıklar hariç aradaki satırları aynı modüle aşağıdaki bloğa uygulayınız. Bu adımdan sonra her değişiklikte yeniden hesaplama yaptığında otomatik çalışması gerekir.

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)

Korhan bey,

Kodu aşağıdaki şekilde Workbook a eklediğimde " For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58") " şeklinde Debug veriyor

Kod:

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Dim Rng As Range, My_Area As Range
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Sheets("Konşimento_Talimatı").Rows("36:58").EntireRow.Hidden = False
  
    For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Korhan Ayhan · 7 Nisan 2023

Böyle deneyiniz.

Eğer yine sorun olursa başka bir yöntem deneriz.

C++:

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Dim Rng As Range, My_Area As Range
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
 
    Sheets("Konşimento_Talimatı").Rows("36:58").EntireRow.Hidden = False
 
    For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True
 
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

gurayavci · 7 Nisan 2023

Korhan Ayhan' Alıntı:

Böyle deneyiniz.

Eğer yine sorun olursa başka bir yöntem deneriz.

C++:

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Dim Rng As Range, My_Area As Range

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Sheets("Konşimento_Talimatı").Rows("36:58").EntireRow.Hidden = False

    For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True

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

Korhan bey Ekteki görseldeki hatayı verdi bu şekilde

Korhan Ayhan · 7 Nisan 2023

Hata veren kod bloğunu silip yerine aşağıdaki kod bloğunu deneyiniz.

C++:

Private Sub Workbook_Activate()
    Dim Rng As Range, My_Area As Range
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Sheets("Konşimento_Talimatı").Rows("36:58").EntireRow.Hidden = False
  
    For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

gurayavci · 7 Nisan 2023

Korhan Ayhan' Alıntı:

Hata veren kod bloğunu silip yerine aşağıdaki kod bloğunu deneyiniz.

C++:

Private Sub Workbook_Activate()
    Dim Rng As Range, My_Area As Range
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Sheets("Konşimento_Talimatı").Rows("36:58").EntireRow.Hidden = False
 
    For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Korhan Bey ilk çalışan kod gibi kapat aç yapınca çalışıyor bu kod

Korhan Ayhan · 7 Nisan 2023

Kurgunuz şu şekilde değilmi...

İki dosya arasında veri bağlantınız var.
İki dosyanız açık durumda verilerin bulunduğu dosyada hedef hücrelerde değişiklik yapıyorsunuz. Sonrasında formülle veri aldığınız dosyanıza geçiş yapıyorsunuz. Son önerdiğim kod bu aşamada devreye girmesi gerekir ve sonuç vermesi gerekir.

gurayavci · 7 Nisan 2023

Korhan Ayhan' Alıntı:
Kurgunuz şu şekilde değilmi...

İki dosya arasında veri bağlantınız var.
İki dosyanız açık durumda verilerin bulunduğu dosyada hedef hücrelerde değişiklik yapıyorsunuz. Sonrasında formülle veri aldığınız dosyanıza geçiş yapıyorsunuz. Son önerdiğim kod bu aşamada devreye girmesi gerekir ve sonuç vermesi gerekir.

Korhan Bey , dosyanın tam halini ekledim,,

3 sayfa var dosyada

Packing list sayfasındaki ürün kategorileri sütununda değişiklik olduğunda (ürün kategorisi clamp ise Clamp ile ilişkili satıra veri gidiyor yada Disc diffuser ise o satır hareketleniyor fakat kapat aç yapınca şu an kod çalışıyor

ilişkili sayfalar Packing_list ve Konşimento

Korhan Ayhan · 7 Nisan 2023

İlk mesajınızda tek sayfa içeren dosya paylaşınca bende başka bir excelden verileri aldığınızı düşünmüştüm.

Aşağıdaki kodu deneyiniz. Packing_List sayfasının kod bölümüne uygulayınız. E14:E33 arasında değişiklik yaptığınızda çalışması gerekir.

C++:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range, My_Area As Range
    
    If Intersect(Target, Range("E14:E33")) Is Nothing Then Exit Sub
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Sheets("Konşimento_Talimatı").Rows("36:58").EntireRow.Hidden = False
  
    For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

gurayavci · 7 Nisan 2023

Korhan Ayhan' Alıntı:

İlk mesajınızda tek sayfa içeren dosya paylaşınca bende başka bir excelden verileri aldığınızı düşünmüştüm.

Aşağıdaki kodu deneyiniz. Packing_List sayfasının kod bölümüne uygulayınız. E14:E33 arasında değişiklik yaptığınızda çalışması gerekir.

C++:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range, My_Area As Range
   
    If Intersect(Target, Range("E14:E33")) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Sheets("Konşimento_Talimatı").Rows("36:58").EntireRow.Hidden = False
 
    For Each Rng In Sheets("Konşimento_Talimatı").Range("H36:H58")
        If Rng = 0 Then
            If My_Area Is Nothing Then
                Set My_Area = Rng
            Else
                Set My_Area = Union(My_Area, Rng)
            End If
        End If
    Next

    If Not My_Area Is Nothing Then My_Area.EntireRow.Hidden = True
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Korhan Bey Muhteşem oldu Teşekkür ederimmmmm

Hücre gizleme Makrosu - belli bir satırdan sonrası

gurayavci

Ekli dosyalar

palhex

ridvanucok

gurayavci

gurayavci

gurayavci

Korhan Ayhan

Administrator

gurayavci

Ekli dosyalar

Korhan Ayhan

Administrator

gurayavci

Korhan Ayhan

Administrator

gurayavci

Korhan Ayhan

Administrator

gurayavci

Ekli dosyalar

Korhan Ayhan

Administrator

gurayavci

Korhan Ayhan

Administrator

gurayavci

Ekli dosyalar

Korhan Ayhan

Administrator

gurayavci