• DİKKAT

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

Merhaba bu kodu hızlandırmak ve bağımlı olduğu modül deki kodlardan kurtarmak mümkün müdür

  • Konbuyu başlatan Konbuyu başlatan Akif59
  • Başlangıç tarihi Başlangıç tarihi
A

Akif59

Katılım
15 Mart 2020
Mesajlar
66
Excel Vers. ve Dili
2013 ve 2016
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
For i = 32 To 64
If Target.Address = Cells(i, 3).Address Then
Select Case Target.Value
Case Is = ""
Call Rows1
Case Is <> ""
Call Rows2
End Select
End If
Next i
For i = 83 To 115
If Target.Address = Cells(i, 3).Address Then
Select Case Target.Value
Case Is = ""
Call Rows3
Case Is <> ""
Call Rows4
End Select
End If
Next i
For i = 33 To 110
If Target.Address = Cells(12, i).Address Then
Select Case Target.Value
Case Is <> ""
Call Columns1
Case Is = ""
Call Columns2
End Select
End If
Next i
End Sub







Sub Columns1()
Application.ScreenUpdating = False
For i = 33 To 110
If Cells(12, i) <> "" Then
Columns(i + 3).EntireColumn.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub


Sub Columns2()
Application.ScreenUpdating = False
For i = 33 To 110
If Cells(12, i) = "" Then
Columns(i + 3).EntireColumn.Hidden = True
End If
Next i
Application.ScreenUpdating = True
End Sub


Sub Rows1()
Application.ScreenUpdating = False
For i = 32 To 64
If Cells(i - 1, 3) = "" Then
Rows(i + 3).EntireRow.Hidden = True
End If
Next i
Application.ScreenUpdating = True
End Sub


Sub Rows2()
Application.ScreenUpdating = False
For i = 32 To 64
If Cells(i - 1, 3) <> "" Then
Rows(i + 3).EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub


Sub Rows3()
Application.ScreenUpdating = False
For i = 83 To 115
If Cells(i - 1, 3) = "" Then
Rows(i + 3).EntireRow.Hidden = True
End If
Next i
Application.ScreenUpdating = True
End Sub


Sub Rows4()
Application.ScreenUpdating = False
For i = 83 To 115
If Cells(i - 1, 3) <> "" Then
Rows(i + 3).EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub
 
Bu kodlarla ne yapmak istediğinizi açıklarsanız daha iyi olur bence.
 
YUSUF44' Alıntı:
Bu kodlarla ne yapmak istediğinizi açıklarsanız daha iyi olur bence.
Genişletmek için tıkla ...
https://www.dosyaupload.com/7bm1

merhaba yukarıdaki kodlar

C sütununda yeni pastal no girdiğimde bana yeni satırlar açıyor

12 nolu satırada yeni bedenler girdiğimde ise yeni sütunlar açıyor kod şu an çalışır durumda

yapmak istediğim şey adres olarak gösterdiğim kodları da asıl kodun içine almak ve adres gösterdiğim kodlardan kurtulmak

asıl kodlar ve adres gösterdiğim kodlar yukarıdadır orijinal dosyada ektedir yardımcı olabilecek arkadaşlara şimdiden teşekkür ederim
 
Change kodlarındaki 3 tane For döngüsüne neden ihtiyaç duydunuz?
 
YUSUF44' Alıntı:
Change kodlarındaki 3 tane For döngüsüne neden ihtiyaç duydunuz?
Genişletmek için tıkla ...
ilgili alanlara veri girdiğim de yeni satır ve sutun açtığı gibi sildiğimdede satır ve sütunları gizliyor kodların içinde fazla komutlar olabilir bu haliyle cok ağğır çalıştığı için kodu bir bütün haline getirip adres gösterdiğim kodlardan kurtulmaya çalıştım fakat beceremedim
 
Akif59' Alıntı:
ilgili alanlara veri girdiğim de yeni satır ve sutun açtığı gibi sildiğimdede satır ve sütunları gizliyor kodların içinde fazla komutlar olabilir bu haliyle cok ağğır çalıştığı için kodu bir bütün haline getirip adres gösterdiğim kodlardan kurtulmaya çalıştım fakat beceremedim
Genişletmek için tıkla ...
igili kod iki farklı satır ve bir sütun aralığında işlev görüyor tüm CheckBox ları işaretlediğinizde dosyanın tamamı görünür hale gelecektir
 
Yapmak istediğinizle kodlarınızı bağdaştırmakta zorlanıyorum. Eski kodlarınızı unutun, dosyanızda hiç makro yokmuş gibi düşünün. Nerede ne olduğunda makronun ne yapmasını istiyorsunuz? Bunu açıklayın ona göre yeni kod yazalım olur mu?
 
YUSUF44' Alıntı:
Yapmak istediğinizle kodlarınızı bağdaştırmakta zorlanıyorum. Eski kodlarınızı unutun, dosyanızda hiç makro yokmuş gibi düşünün. Nerede ne olduğunda makronun ne yapmasını istiyorsunuz? Bunu açıklayın ona göre yeni kod yazalım olur mu?
Genişletmek için tıkla ...
YUSUF44' Alıntı:
Yapmak istediğinizle kodlarınızı bağdaştırmakta zorlanıyorum. Eski kodlarınızı unutun, dosyanızda hiç makro yokmuş gibi düşünün. Nerede ne olduğunda makronun ne yapmasını istiyorsunuz? Bunu açıklayın ona göre yeni kod yazalım olur mu?
Genişletmek için tıkla ...
Yusuf bey 12 nolu satıra sağa doğru iki haneli değerler girin 33 nolu sütüna geldiğinizde size 110 nolu sütüna kadar yeni sütunlar açacaktır sildiğimiz dede bunları geri toplayacaktır

yine c sütüünunda aşağıya doğru pastal no altında 18 satır 67 satır arasında yeni girişler yaptığınızda yeni satırlar açacaktır
69 satır 118 satır arasında yeni girişler yaptığınızda yeni satırlar açacaktır


girilen değerleri sildiğimiz dede tekrar gizleyecektir örenk dosyada ilgili alanlara giriş yapabilirseniz ve sonra silebilirsiniz
 
Aşağıdaki gibi bir çözüm mü arıyorsunuz?

PHP: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, [AG12:DH12]) Is Nothing Then GoTo 10
Application.ScreenUpdating = False
    If Target = "" Then
        Columns(Target.Column).EntireColumn.Hidden = True
    Else
        Columns(Target.Column + 1).EntireColumn.Hidden = False
    End If
Application.ScreenUpdating = True
10:
If Intersect(Target, [C34:C66, C84:C117]) Is Nothing Then GoTo 20
Application.ScreenUpdating = False
    If Target = "" Then
        Rows(Target.Row).EntireRow.Hidden = True
    Else
        Rows(Target.Row + 1).EntireRow.Hidden = False
    End If
Application.ScreenUpdating = True
20:
If Intersect(Target, [AF12]) Is Nothing Then GoTo 30
Application.ScreenUpdating = False
    If Target <> "" Then
        Columns(Target.Column + 1).EntireColumn.Hidden = False
    End If
Application.ScreenUpdating = True
30:
If Intersect(Target, [C33, C83]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
    If Target <> "" Then
        Rows(Target.Row + 1).EntireRow.Hidden = False
    End If
Application.ScreenUpdating = True

End Sub
 
YUSUF44' Alıntı:
Aşağıdaki gibi bir çözüm mü arıyorsunuz?

PHP: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, [AG12:DH12]) Is Nothing Then GoTo 10
Application.ScreenUpdating = False
    If Target = "" Then
        Columns(Target.Column).EntireColumn.Hidden = True
    Else
        Columns(Target.Column + 1).EntireColumn.Hidden = False
    End If
Application.ScreenUpdating = True
10:
If Intersect(Target, [C34:C66, C84:C117]) Is Nothing Then GoTo 20
Application.ScreenUpdating = False
    If Target = "" Then
        Rows(Target.Row).EntireRow.Hidden = True
    Else
        Rows(Target.Row + 1).EntireRow.Hidden = False
    End If
Application.ScreenUpdating = True
20:
If Intersect(Target, [AF12]) Is Nothing Then GoTo 30
Application.ScreenUpdating = False
    If Target <> "" Then
        Columns(Target.Column + 1).EntireColumn.Hidden = False
    End If
Application.ScreenUpdating = True
30:
If Intersect(Target, [C33, C83]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
    If Target <> "" Then
        Rows(Target.Row + 1).EntireRow.Hidden = False
    End If
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...
Elinize sağlık Yusuf bey çok başarılı küçük düzenlemeler yapmamız mümkün müdür
12 satıra veri girildiğinde sütun açtırdığımız döngüde sonda sürekli 3 adet boş hücre kalması gerekiyor
ve yine satır açtırır ikende yine her iki aralığın sonunda üç hüçrenin boş kalması gerekiyor eski kodumuz bu şekilde idi
 
Şöyle dener misiniz?

PHP: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, [AG12:DH12]) Is Nothing Then GoTo 10
Application.ScreenUpdating = False
    If Target = "" Then
        Columns(Target.Column).EntireColumn.Hidden = True
    Else
        Columns(Target.Column + 1).EntireColumn.Hidden = False
        Columns(Target.Column + 2).EntireColumn.Hidden = False
        Columns(Target.Column + 3).EntireColumn.Hidden = False
    End If
Application.ScreenUpdating = True
10:
If Intersect(Target, [C34:C66, C84:C117]) Is Nothing Then GoTo 20
Application.ScreenUpdating = False
    If Target = "" Then
        Rows(Target.Row).EntireRow.Hidden = True
    Else
        Rows(Target.Row + 1 & ":" & Target.Row + 3).EntireRow.Hidden = False
    End If
Application.ScreenUpdating = True
20:
If Intersect(Target, [AF12]) Is Nothing Then GoTo 30
Application.ScreenUpdating = False
    If Target <> "" Then
        Columns(Target.Column + 1).EntireColumn.Hidden = False
        Columns(Target.Column + 2).EntireColumn.Hidden = False
        Columns(Target.Column + 3).EntireColumn.Hidden = False
    End If
Application.ScreenUpdating = True
30:
If Intersect(Target, [C33, C83]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
    If Target <> "" Then
        Rows(Target.Row + 1 & ":" & Target.Row + 3).EntireRow.Hidden = False
    End If
Application.ScreenUpdating = True

End Sub
 
YUSUF44' Alıntı:
Şöyle dener misiniz?

PHP: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, [AG12:DH12]) Is Nothing Then GoTo 10
Application.ScreenUpdating = False
    If Target = "" Then
        Columns(Target.Column).EntireColumn.Hidden = True
    Else
        Columns(Target.Column + 1).EntireColumn.Hidden = False
        Columns(Target.Column + 2).EntireColumn.Hidden = False
        Columns(Target.Column + 3).EntireColumn.Hidden = False
    End If
Application.ScreenUpdating = True
10:
If Intersect(Target, [C34:C66, C84:C117]) Is Nothing Then GoTo 20
Application.ScreenUpdating = False
    If Target = "" Then
        Rows(Target.Row).EntireRow.Hidden = True
    Else
        Rows(Target.Row + 1 & ":" & Target.Row + 3).EntireRow.Hidden = False
    End If
Application.ScreenUpdating = True
20:
If Intersect(Target, [AF12]) Is Nothing Then GoTo 30
Application.ScreenUpdating = False
    If Target <> "" Then
        Columns(Target.Column + 1).EntireColumn.Hidden = False
        Columns(Target.Column + 2).EntireColumn.Hidden = False
        Columns(Target.Column + 3).EntireColumn.Hidden = False
    End If
Application.ScreenUpdating = True
30:
If Intersect(Target, [C33, C83]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
    If Target <> "" Then
        Rows(Target.Row + 1 & ":" & Target.Row + 3).EntireRow.Hidden = False
    End If
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...
Elinize sağlık Yusuf bey çok güzel oldu minnettarım
bende böyle bir şey yapmıştım çok güzel çalışıyor fakat sizinkinin yanında hali hazırda 3 viteste giden bir aracı 1 viteste sabitlemiş gibi ağır çalışan bir şey ortaya çıktı kendimi geliştirmek adına soruyorum neresinde hata yapmışım cevaplarsanız sevinirim

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
For i = 32 To 64
If Cells(i - 1, 3) <> "" Then
Rows(i + 3).EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
For i = 32 To 64
If Cells(i - 1, 3) = "" Then
Rows(i + 3).EntireRow.Hidden = True
End If
Next i
Application.ScreenUpdating = True
For i = 83 To 115
If Cells(i - 1, 3) <> "" Then
Rows(i + 3).EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
For i = 83 To 115
If Cells(i - 1, 3) = "" Then
Rows(i + 3).EntireRow.Hidden = True
End If
Next i
Application.ScreenUpdating = True

For i = 33 To 110
If Cells(12, i) <> "" Then
Columns(i + 3).EntireColumn.Hidden = False
End If
Next i
Application.ScreenUpdating = True
For i = 33 To 110
If Cells(12, i) = "" Then
Columns(i + 3).EntireColumn.Hidden = True
End If
Next i
Application.ScreenUpdating = True
End Sub
 
Sizin kodlarda her işlemde döngülerde belirtilen tüm satır ve sütunlar ayrı ayrı kontrol edilip şarta uyuyorsa gizleniyor ya da gösteriliyordu. Benim verdiğim kodda ise döngü kullanmadan kendinden sonraki 3 sütun/satır doğrudan gizleniyor ya da açılıyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst