İki farklı prosedürü aynı sayfa çalıştırma

[mars2]

İyi Günler;
Çalışma kitabının üç sayfası bulunmakta olup;
1. sayfanın adı "yıllar"
2. sayfanın adı "liste"
3. sayfanın adı ise "hesaplar" dır.

Yıllar sayfasının B12 hücresine ismi yazdığımız zaman, B4, B5, B6, B7, B8 hücrelerine liste sayfasında veriler aktarılmkatadır.
Ancak, Yıllar sayfasını B24 ve B25 hücrelerine B4 hücressindeki dosya nosu dikkate alınarak "hesaplar" sayfasından veri aktarmak istiyorum.
Aynı sayfada iki farklı makronun birlikte çalışmamsını istiyorum. Ancak B24 ve B25 hücrelerine hesaplar sayfasından veri aktarılmmaktadır.

Aşağıdaki kodda nerede bir yanlşılık yapmış olabilirim. Bu konuda yardımlarınızı beklemekteyim.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [B12]) Is Nothing Then Exit Sub
If Target.Value = Empty Then Exit Sub

Set s1 = Sheets("yıllar")
Set s2 = Sheets("liste")
Set s3 = Sheets("hesaplar")

For Each bul In s2.Range("N5:N100")
If bul = Target.Value Then sat = bul.Row
Next
If sat = "" Then
MsgBox "Aradığınız kişi bulunamadı.", vbInformation, "Bilgi"
Exit Sub
End If

s1.Cells(4, "B").Value = s2.Cells(sat, "B").Value
s1.Cells(7, "B").Value = s2.Cells(sat, "C").Value
s1.Cells(8, "B").Value = s2.Cells(sat, "D").Value

Set s1 = Nothing
Set s2 = Nothing

If Intersect(Target, [B4]) Is Nothing Then Exit Sub
If Target.Value = Empty Then Exit Sub

Set s1 = Sheets("yıllar")
Set s3 = Sheets("hesaplar")

For Each bul In s3.Range("B5:B100")
If bul = Target.Value Then sat = bul.Row

Next

If sat = "" Then
MsgBox "Aradığınız kişi bulunamadı.", vbInformation, "Bilgi"
Exit Sub
End If
s1.Cells(24, "B").Value = s3.Cells(sat, "M").Value
s1.Cells(25, "B").Value = s3.Cells(sat, "N").Value
Set s3 = Nothing

End Sub

 

[mars2]

İyi Günler;
Konu hakkında ilginizi beklemekteyim. Örnek doya ektedir.

 

[uzmanamele]

Merhaba

If Intersect(Target, [B12]) Is Nothing Then Exit Sub

Veri girişi B12 hücresinde değilse prosedür sonlanacaktır.
Dolayısıyla B4 hücresine veri girildiğinde makro tetiklenemez.

Kodunuzu bu doğrultuda revize ediniz.

 

[Murat OSMA]

Alternatif olarak şu kodları kullanabilirsiniz;

'*******************************************
'**                ¯/ /¯/ / ¯/              **
'** MuratOSMA ©  /¯  / / / ¯/  © Rky         **
'**              ¯   ¯    ¯                **
'*******************************************
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "B12" Then
      If Target.Value = "" Then Range("B4:B25").ClearContents
        For i = 2 To Sayfa2.Range("N65536").End(3).Row
            bul = Target.Value: a = 0
            On Error GoTo hata
            a = WorksheetFunction.Match(bul, Sayfa2.Range("N:N"), 0)
        If a > 0 Then
            Range("B4").Value = Sayfa2.Cells(a, 2)
            Range("B6").Value = Sayfa2.Cells(a, 3)
            Range("B8").Value = Sayfa2.Cells(a, 4)
                Else
            MsgBox "YOK"
        End If
            bul = Range("B4").Value: a = 0
            a = WorksheetFunction.Match(bul, Sayfa3.Range("B:B"), 0)
        If a > 0 Then
            Range("B25").Value = Sayfa3.Cells(a, "N")
            Range("B24").Value = Sayfa3.Cells(a, "M")
                Else
            MsgBox "YOK"
        End If
        Next i
    End If
hata:
End Sub

■ B12 hücresine isim yazarak deneyin.

 

[mars2]

İlhginize teşekkürler;
İlk önce B12 hücresine isim yazdığım zaman B4; B5,B6,B7 ve B8 hücrelerine liste sayfasından veri geliyor. Benim istediğim B4 hücresine gelen no'dan B24 ve B25 hücrelerine hesaplar saydasından hesap nolarının gelmesini istemekteyim.

 

[Murat OSMA]

Verdiğim kodları denediniz mi ? :dusun:
Kodlarda sorun mu var ? :dusun:

 

[mars2]

Sayın Murat Osman;
İlginize teşekkürler.
Herhangi bir sorun bulunmmaktadır.