• DİKKAT

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

Aynı Sayfa içinde 2 tane Private Sub Worksheet_Change Kullanmak

M

Metin_S

Katılım
20 Kasım 2009
Mesajlar
89
Excel Vers. ve Dili
MS Office 2016 TR
Herkese merhaba,

Aynı sayfa içinde 2 tane Private Sub Worksheet_Change kullanmam gerekiyor fakat yapamadım. Aslında kullanacağım kod aynı fakat farklı hücrelere farklı işlem yapmasını istiyorum. Yardımlarınız içim şimdiden teşekkür ederim.
 
Metin_S' Alıntı:
Herkese merhaba,

Aynı sayfa içinde 2 tane Private Sub Worksheet_Change kullanmam gerekiyor fakat yapamadım. Aslında kullanacağım kod aynı fakat farklı hücrelere farklı işlem yapmasını istiyorum. Yardımlarınız içim şimdiden teşekkür ederim.
Genişletmek için tıkla ...
Ayni sayfa modülü içinde 1den fazla ayni adla sub prosedür veya function kullanamazsınız.
Kodlarınızı bu durumu göz önüne alarak yazınız.:cool:
 
Sayın Evren_Gizlen merhaba,

Daha önce yine sizin yardımınızla yaptığımız bir çalışma vardı. Şimdi onunla ilgil değişiklik yapmam gerekti. Eminimki bana yardımcı olabilirsiniz.

Sayfada kullanılan ilk Private Sub Worksheet_Change

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D9, W9, D27, W27, D45, W45, D63, W63, D81, W81]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo Hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(-1, 0).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(-1, 0).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
Hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("c:\Fotolar\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(-1, 0).Top
Selection.Left = Target.Offset(-1, 0).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
'Selection.ShapeRange.Height = Target.Offset(-1, 0).Height
'Selection.ShapeRange.Width = Target.Offset(-1, 0).Width
Selection.ShapeRange.Height = 73
Selection.ShapeRange.Width = 60
Selection.ShapeRange.IncrementLeft 2.25 'beş sağ ok tuşu
Selection.ShapeRange.IncrementTop 2.25 'bir sağ ok tuşu
Target.Select
son:
End Sub

2.kullanmak istideğim Private Sub Worksheet_Change

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [O4, AH4]) Is Nothing Then Exit Sub
If Target.Row Mod 50 = 0 Then Exit Sub
On Error GoTo Hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(-1, 0).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(-1, 0).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
Hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("c:\Fotolar\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(-1, 0).Top
Selection.Left = Target.Offset(-1, 0).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
'Selection.ShapeRange.Height = Target.Offset(-1, 0).Height
'Selection.ShapeRange.Width = Target.Offset(-1, 0).Width
Selection.ShapeRange.Height = 18
Selection.ShapeRange.Width = 15
Target.Select
son:
End Sub

aslında aynı işlemi yapacak fakat aynı sayfa içindeki farklı hücrelere farklı boyutları uygulayacak bu sorunu farklı bir şekilde nasıl çözebiliriz acaba. Yardımcı olabilirsen çok sevinirim. Şimdiden teşekkür ederim.
 
Son düzenleme:
Aşağıdaki şekilde denermisiniz.


Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D9, W9, D27, W27, D45, W45, D63, W63, D81, W81]) Is Nothing Then
GoTo f
Else
Call kod1
End If
f:
If Intersect(Target, [O4, AH4]) Is Nothing Then
Exit Sub
Else
Call kod2
End If
End Sub



Sub kod1()
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo Hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(-1, 0).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(-1, 0).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
Hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("c:\Fotolar\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(-1, 0).Top
Selection.Left = Target.Offset(-1, 0).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
'Selection.ShapeRange.Height = Target.Offset(-1, 0).Height
'Selection.ShapeRange.Width = Target.Offset(-1, 0).Width
Selection.ShapeRange.Height = 73
Selection.ShapeRange.Width = 60
Selection.ShapeRange.IncrementLeft 2.25 'beş sağ ok tuşu
Selection.ShapeRange.IncrementTop 2.25 'bir sağ ok tuşu
Target.Select
son:
End Sub


Sub kod2()
If Target.Row Mod 50 = 0 Then Exit Sub
On Error GoTo Hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(-1, 0).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(-1, 0).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
Hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("c:\Fotolar\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(-1, 0).Top
Selection.Left = Target.Offset(-1, 0).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
'Selection.ShapeRange.Height = Target.Offset(-1, 0).Height
'Selection.ShapeRange.Width = Target.Offset(-1, 0).Width
Selection.ShapeRange.Height = 18
Selection.ShapeRange.Width = 15
Target.Select
son:
End Sub
 
Hata verdi

Sayın Husgvarna merhaba,

İlginiz için teşekkür edrim ama hata verdi hatayı resim olarak ekliyorum.
 

Ekli dosyalar

  • hata.jpg
    hata.jpg
    41.1 KB · Görüntüleme: 11
alternatif kod

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D9, W9, D27, W27, D45, W45, D63, W63, D81, W81,O4, AH4]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Or Target.Row Mod 50 = 0 Then Exit Sub
On Error GoTo Hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(-1, 0).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(-1, 0).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
Hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("c:\Fotolar\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(-1, 0).Top
Selection.Left = Target.Offset(-1, 0).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
If Intersect(Target, [O4, AH4]) Is Nothing Then
Selection.ShapeRange.Height = 73
Selection.ShapeRange.Width = 60
Selection.ShapeRange.IncrementLeft 2.25 'beş sağ ok tuşu
Selection.ShapeRange.IncrementTop 2.25 'bir sağ ok tuşu
Else
Selection.ShapeRange.Height = 18
Selection.ShapeRange.Width = 15
End If
Target.Select
son:
End Sub
Genişletmek için tıkla ...
 
Sayın halit3 merhaba,

Kod işe yaradı teşekkür ederim. Yalnız bir sorun var If Intersect(Target, [O4, AH4]) Is Nothing Then bölümündeki O4 ve AH4 hücrelerini örnek yazmıştım aynı yere BB16 hücresinide ekledim ama orada işe yaramadı sebebi ne olabilir. If Target.Row Mod 20 = 0 Or Target.Row Mod 50 = 0 Then Exit Sub bu kod ile alakası olabilirmi ben biraz uğraştım ama BB16 hücresine resimi getiremedim.

Yardımlarınız için şimdiden çok teşekkür ederim.
 
birde böyle deneyiniz.
Private Sub Worksheet_Change(ByVal Target As Range)
'If Intersect(Target, [D9, W9, D27, W27, D45, W45, D63, W63, D81, W81,O4, AH4]) Is Nothing Then Exit Sub
If Intersect(Target, [D9, W9, D27, W27, D45, W45, D63, W63, D81, W81,BB16]) Is Nothing Then Exit Sub
'If Target.Row Mod 20 = 0 Or Target.Row Mod 50 = 0 Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
If Target.Row Mod 50 = 0 Then Exit Sub
On Error GoTo Hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(-1, 0).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(-1, 0).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
Hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("c:\Fotolar\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(-1, 0).Top
Selection.Left = Target.Offset(-1, 0).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
'If Intersect(Target, [O4, AH4]) Is Nothing Then
If Intersect(Target, [BB16]) Is Nothing Then
Selection.ShapeRange.Height = 73
Selection.ShapeRange.Width = 60
Selection.ShapeRange.IncrementLeft 2.25 'beş sağ ok tuşu
Selection.ShapeRange.IncrementTop 2.25 'bir sağ ok tuşu
Else
Selection.ShapeRange.Height = 18
Selection.ShapeRange.Width = 15
End If
Target.Select
son:
End Sub
Genişletmek için tıkla ...
 
Sayın halit3 merhaba,

Düzeltmelerini kullandım sorun düzeldi çok teşekkür ederim. Çok olmuyorsam birşey sormak istiyorum. Ben sizin gibi uzman değilim hatta acemi sayılırım. O yüzden sorduğum sorular size garip gelebilir şimdiden kusuruma bakmayın lütfen. Kodda yaptığım son düzenleme aşağıda burada soracağım 2 şey var.

Kodun son hali:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A2:BU65536]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
If Target.Row Mod 50 = 0 Then Exit Sub
On Error GoTo Hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(-1, 0).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(-1, 0).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
Hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("c:\Fotolar\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(-1, 0).Top
Selection.Left = Target.Offset(-1, 0).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
If Intersect(Target, [O4,AH4,BB14,AH76,BU86]) Is Nothing Then
Selection.ShapeRange.Height = 73
Selection.ShapeRange.Width = 60
Selection.ShapeRange.IncrementLeft 2.25
Selection.ShapeRange.IncrementTop 2.25
Else
Selection.ShapeRange.Height = 35
Selection.ShapeRange.Width = 37
End If
Target.Select
son:
End Sub

1.Soru
Kodun içindeki kırmızı renk ile belirttiğim tam olarak ne iş yapıyor

2.Soru
Kodun içindeki yeşil renk ile belirttiğim yerlerde 2 farklı boyutlandırma var ben buraya 3cü bir boyut eklemek istersem nasıl yapabilirim.

YARDIMLARINIZ İÇİN ŞİMDİDEN ÇOK TEŞEKKÜR EDERİM.
 
dilimin döndüğünce anlatmaya çalışıyım.


If Target.Row Mod 20 = 0 Then Exit Sub



yirminci satır sıfır değerini verir ayrıca yirmibirinci satırdan itibaren birden yeniden sayar

örnek olarak 63 satır burada 3 değerini verir yani her yirmi satırdan sonra satır numaralarını sıfırlar. diğeride bunun gibi aynen

diğer soruna gelince

Selection.ShapeRange.Height = 73
Selection.ShapeRange.Width = 60

Selection aktif hücre
sayfanda obje yani nesne var gibi görüküyor örnek olarak bir resim nesnesinin ShapeRange.Height yüksekliğini ShapeRange.Width genişliğini gösterir
 
Sayın halit3 herşey için çok teşekkür ederim. Eline, diline sağlık...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst