• DİKKAT

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

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

G

gurayavci

Katılım
9 Ocak 2020
Mesajlar
48
Excel Vers. ve Dili
2010
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
 

Ekli dosyalar

Dosyayı indiremiyorum...
Bir dosya paylaşım sitesine atma şansınız var mı?
Teşekkürler.
 
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
 
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
Genişletmek için tıkla ...


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ı
 
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
 
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
Genişletmek için tıkla ...



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
"""
 

Ekli dosyalar

Ç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.
 
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
 
Ö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 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)
Genişletmek için tıkla ...
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
 
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 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
Genişletmek için tıkla ...

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

Ekli dosyalar

  • resim_2023-04-07_111050301.png
    resim_2023-04-07_111050301.png
    33.6 KB · Görüntüleme: 1
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 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
Genişletmek için tıkla ...


Korhan Bey ilk çalışan kod gibi kapat aç yapınca çalışıyor bu kod
 
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 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.
Genişletmek için tıkla ...


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
 

Ekli dosyalar

İ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 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
Genişletmek için tıkla ...
Korhan Bey Muhteşem oldu Teşekkür ederimmmmm :):):)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst