Worksheet_Change if else ile kullanma nasıl ?

[eneskus]

Arkadaşlar Worksheet_Change bir adet yazılıyormuş öğrenmiş olduk.
Ancak bu kod if else end if ile birleştirilerek coğaltıla biliyormuş.
eklediğim dosyada veri sayfası ve veri (2) sayfası var.
veri sayfasında 1200 adet if else end if formülü var çalışmıyor.
veri (2) de 300 adet if else end if le var çalışmakta.

acaba bunun bir sınırımı var yoksa başka bir hata mı var. yardımcı olursanız sevinirim.

 

[uzmanamele]

Merhaba

1200*2=2400 adet prosedür!
Çok sabırlıymışsınız.
Tek bir prosedürle yapabilirsiniz.
Veri girişinin yapıldığı satır nosunu kullanarak a prosedüründen 1 tane yazmanız yeterli olur.

 

[eneskus]

Malesef presedür ile çalışan makro eğer genel için olursa 1 hüçre değiştiğinde 25 dk da bile bitmemekte bu nedenle her satır için ayrı ayrı makro ve presedür yapmam gerekti. o bile 10-15 sn kum saati dönmesine neden olmakta ama işimi görmekte şimdilik o nedenle bu şekilde yapmak zorunda kaldım.
Yardımlarınızı beklemekteyim.

 

[Necdet]

Merhaba,

Siz nasıl yaptığınızı değil ne olması gerektiğini anlatın, çözüm o yönde olsun.

 

[eneskus]

Merhaba,

Siz nasıl yaptığınızı değil ne olması gerektiğini anlatın, çözüm o yönde olsun.

Aşağıdaki makro hata veriyor. ( Makro 1200 makroyu çalıştırdığından kısalttım gercek makro ilk mesajdaki ekli dosyada var)

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("u2,w2,y2,aa2,ac2,ae2")) Is Nothing Then
GoTo b1
Else
Call a1
End If
b1:
If Intersect(Target, Range("u3,w3,y3,aa3,ac3,ae3")) Is Nothing Then
GoTo b2
Else
Call a2
End If
b2:
If Intersect(Target, Range("u4,w4,y4,aa4,ac4,ae4")) Is Nothing Then
GoTo b3
Else
Call a3
End If
b3:
.
.
.
.
.
b1199:
If Intersect(Target, Range("u320,w320,y320,aa320,ac320,ae320")) Is Nothing Then
Else
Call a1200
End If
End Sub

Makro en son satır End sub da hata veriyor. Hatayı nasıl giderebiliriz.

 

[Murat OSMA]

Sn. eneskus, o kadar satırı nasıl yazdınız ?
İpucu vereyim: satır satır değil de sütun olarak yazmayı deneyin;

Örnek; bu satırların ve diğer aşağıya doğru uzanan satırların yerine;

If Not Intersect(Target, Range("u2,w2,y2,aa2,ac2,ae2"))
If Not Intersect(Target, Range("u3,w3,y3,aa3,ac3,ae3"))
.................

if target.column = 21 or target.column = 23 or target.column = 25 or target.column = 27 or target.column = 29 or target.column = 31 then

yazabilirsiniz...

 

[eneskus]

Sn. eneskus, o kadar satırı nasıl yazdınız ?
İpucu vereyim: satır satır değil de sütun olarak yazmayı deneyin;

Örnek; bu satırların ve diğer aşağıya doğru uzanan satırların yerine;

If Not Intersect(Target, Range("u2,w2,y2,aa2,ac2,ae2"))
If Not Intersect(Target, Range("u3,w3,y3,aa3,ac3,ae3"))
.................

if target.column = 21 or target.column = 23 or target.column = 25 or target.column = 27 or target.column = 29 or target.column = 31 then

yazabilirsiniz...

Anlatmak istediğinizi şu şekilde anladım: 1200 satır yerine 6 sütun ile yap demek istemişsiniz. ancak tek satırda 6 hüçrede işlem yapar iken bile 5-6 sn kum saati dönmekte ( calıştırdığı makro 300 sütunda veri aramakta ve bulunan değerle ilgili satıra veri kopyalamakta). Bu nedenle excel dosyasındaki kilitlenmelerin ve donmaların önüne makro satırını 1200 yaparak bir sefer yazmaya uğrastım ve yazdım. bu şekilde yapmamın nedeni budur.

 

[Murat OSMA]

Siz de 6 sütunda işlem yaptırmıyor musunuz ? :dusun:

If Not Intersect(Target, Range("u2,w2,y2,aa2,ac2,ae2"))
Neyse...

Kodlarınızı detaylıca incelemedim ama yapmak istediğiniz her neyse, sizin yönteminizle yapmanın doğru olmayacağını düşünüyorum.

İyi günler...

 

[eneskus]

Siz de 6 sütunda işlem yaptırmıyor musunuz ? :dusun:

If Not Intersect(Target, Range("u2,w2,y2,aa2,ac2,ae2"))
Neyse...

Kodlarınızı detaylıca incelemedim ama yapmak istediğiniz her neyse, sizin yönteminizle yapmanın doğru olmayacağını düşünüyorum.

İyi günler...

Anladığımı yazmıştım ben 6 sütun değil 6 hüçrede işlem yaptırıyorum. Ancak 1200 satırda işlem yaptırmam gerekmekte.

Peki başka nasıl bir yöntemle halledebiliriz.

 

[Murat OSMA]

Anlayamıyorum kusura bakmayın. Ben yardımcı olamayacağım...

 

[eneskus]

Anlayamıyorum kusura bakmayın. Ben yardımcı olamayacağım...

ilginiz için teşekkürler.

 

[uzmanamele]

Merhaba

Madem böyle bir yapı ile devam etmek istiyorsunuz, öğleyse en sonra yazdığınız Else'yi siliniz.

If Not Intersect(Target, Range("u1201,w1201,y1201,aa1201,ac1201,ae1201")) Is Nothing Then
Call a1200
                       'Else
  End If
End Sub

 

[Murat OSMA]

Rica ederim, çözümü şimdiden merakla bekleyeceğim...


İyi günler...

 

[eneskus]

Merhaba

Madem böyle bir yapı ile devam etmek istiyorsunuz, öğleyse en sonra yazdığınız Else'yi siliniz.

If Not Intersect(Target, Range("u1201,w1201,y1201,aa1201,ac1201,ae1201")) Is Nothing Then
Call a1200
                       'Else
  End If
End Sub

Malesef aynı hatayı veriyor değişen birşey olmadı.

 

[Necdet]

Merhaba,

a1, a2, a3 diye giden makroların mantığını anlamadım. O yüzden onlara bakmadım.

Aşağıdaki kodu ilgili sayfanın kod bölümüne kopyalayıp deneyiniz. Ancak bunu yapmadan önce a1, a2 diye giden sayfadaki tüm makroları bir modülün içine alın ve adlarının başına "Prog_" sözcüğünü getirin.

Bunu "Sub a" yı buldurup "Sub Prog_a" olarak değiştirerek yapabilirsiniz.

Bir deneyin bakalım kodları.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [U:U, W:W, Y:Y,AA:AA, AC:AC, AE:AE]) Is Nothing Or Target.Row < 2 Then Exit Sub
        
    Dim Prog    As String
    
    Prog = "Prog_a" & Target.Row - 1
    Application.Run CStr(Prog)
 
End Sub

 

[eneskus]

Merhaba,

a1, a2, a3 diye giden makroların mantığını anlamadım. O yüzden onlara bakmadım.

Aşağıdaki kodu ilgili sayfanın kod bölümüne kopyalayıp deneyiniz. Ancak bunu yapmadan önce a1, a2 diye giden sayfadaki tüm makroları bir modülün içine alın ve adlarının başına "Prog_" sözcüğünü getirin.

Bunu "Sub a" yı buldurup "Sub Prog_a" olarak değiştirerek yapabilirsiniz.

Bir deneyin bakalım kodları.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [U:U, W:W, Y:Y,AA:AA, AC:AC, AE:AE]) Is Nothing Or Target.Row < 2 Then Exit Sub
        
    Dim Prog    As String
    
    Prog = "Prog_a" & Target.Row - 1
    Application.Run CStr(Prog)
 
End Sub

Kodlar için teşekkürler.
Ancak sizin verdiğiniz kodlarda işlem 1 satırla sınırlı yani aynı anda u2-u3-u4 satırlarındaki verileri sildiğimde sadece u2 için tanımlı makro çalışmakta. u3-u4 makroları çalışmamakta malesef.

Kodu çoklu makro çalıştıracak şekilde nasıl değiştirebiliriz açaba yani örnek vermek gerekirse u2-u3-u4 verileri değişirse prog_a1 prog_a2 prog_a3 makroları çalışacak tek satırda işlem yapıldığında o satırla ilgili makro çalışacak birden fazla satırda değişiklik yapıldığında değişiklik yapılan satırlarla ilgili tüm makrolar çalışacak şekilde nasıl ayarlaya biliriz acaba.

İlgi ve alakanız için teşekkürler.

 

[uzmanamele]

Merhaba

Necdet beyin dosyasına göre, kodu denemeden yazıyorum, çalışmazsa benzer şekilde düzenleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [U:U, W:W, Y:Y,AA:AA, AC:AC, AE:AE]) Is Nothing Or Target.Row < 2 Then Exit Sub
        
    Dim Prog    As String
    satir = Target.Row
    'Prog = "Prog_a" & Target.Row - 1
    'Application.Run CStr(Prog)
Call Prog_a
End Sub

Public satir As Integer

Sub Prog_a()

    MsgBox "a1 e geldim......"
    
    Dim S1 As Worksheet, S2 As Worksheet
    Dim S1SAT As Long, S1SÜT As Long, _
    S2SAT As Long, S2SÜT As Long
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MAL. MUT.")
    S2.Range("D45:GL45").ClearContents
    Application.ScreenUpdating = False
    'For S2SAT = 45 To 45
    S2SAT = satir + 3
        For S2SÜT = 4 To 389
            For S1SAT = 2 To 2
                For S1SÜT = 20 To 32
                    If S1.Cells(1, S1SÜT) Like "*Malzemenin Cinsi*" Then
                        If S2.Cells(S2SAT, "A") = S1.Cells(S1SAT, "A") And S2.Cells(4, S2SÜT) = S1.Cells(S1SAT, S1SÜT) Then
                                S2.Cells(S2SAT, S2SÜT) = S1.Cells(S1SAT, S1SÜT + 1)
                        End If
                    End If
                Next
            Next
        Next
    'Next
    Application.ScreenUpdating = True
End Sub

 

[eneskus]

Merhaba

Necdet beyin dosyasına göre, kodu denemeden yazıyorum, çalışmazsa benzer şekilde düzenleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [U:U, W:W, Y:Y,AA:AA, AC:AC, AE:AE]) Is Nothing Or Target.Row < 2 Then Exit Sub
        
    Dim Prog    As String
    satir = Target.Row
    'Prog = "Prog_a" & Target.Row - 1
    'Application.Run CStr(Prog)
Call Prog_a
End Sub

Public satir As Integer

Sub Prog_a()

    MsgBox "a1 e geldim......"
    
    Dim S1 As Worksheet, S2 As Worksheet
    Dim S1SAT As Long, S1SÜT As Long, _
    S2SAT As Long, S2SÜT As Long
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MAL. MUT.")
    S2.Range("D45:GL45").ClearContents
    Application.ScreenUpdating = False
    'For S2SAT = 45 To 45
    S2SAT = satir + 3
        For S2SÜT = 4 To 389
            For S1SAT = 2 To 2
                For S1SÜT = 20 To 32
                    If S1.Cells(1, S1SÜT) Like "*Malzemenin Cinsi*" Then
                        If S2.Cells(S2SAT, "A") = S1.Cells(S1SAT, "A") And S2.Cells(4, S2SÜT) = S1.Cells(S1SAT, S1SÜT) Then
                                S2.Cells(S2SAT, S2SÜT) = S1.Cells(S1SAT, S1SÜT + 1)
                        End If
                    End If
                Next
            Next
        Next
    'Next
    Application.ScreenUpdating = True
End Sub

Makrodan yana sıkıntım yok bana makroyu çalıştıracak kod lazım. bu arada kodu çalıştıramadım.

 

[Murat OSMA]

Makrodan yana sıkıntım yok bana makroyu çalıştıracak kod lazım. bu arada kodu çalıştıramadım.

Kusura bakmayın. :hiho::hiho::hiho: :hiho::lol: :lol: :lol: :lol:

 

[uzmanamele]

Makrodan yana sıkıntım yok bana makroyu çalıştıracak kod lazım. bu arada kodu çalıştıramadım.

Ne diyeyim şimdi?!...

Aşağıki mahallede Laz bakkal var, oradan iyi kodlar bulabilirsiniz.