Worksheet_SelectionChange olayının tetiklenmesi

[Karamanli.70]

Arkadaşlar kolay gelsin Excel VBA da "Worksheet_SelectionChange" olayının tetiklenmesi için malum hücreler içinde gezinmek yeterli. Peki bu olayı bir buttona nasıl atayabiliriz.?

 

[Muzaffer Ali]

Merhaba aşağıdaki gibi yapabilirsiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    MsgBox Target.Text
End Sub

Sub test()
    Worksheet_SelectionChange ActiveCell
End Sub

 

[Korhan Ayhan]

Ben talebinizi şu şekilde anladım.

SelectionChange altındaki kodu buton ile istediğiniz zaman çalıştırıp-durdurabilmek..

Eğer istediğiniz işlem buysa aşağıdaki yapıyı deneyebilirsiniz.

Boş bir modüle;

Bu kodu sayfaya bir buton ekleyerek tanımlayın. Butona ilk tıkladığınızda makro aktif olur. İkinci kez tıkladığınızda SelectionChange kodu pasif duruma geçer.

Option Explicit
Public Kontrol As Boolean

Sub Aktif_Pasif()
    Kontrol = Not Kontrol
End Sub

Sayfadaki kodunuzu da aşağıdaki gibi düzenleyiniz.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Kontrol = True Then Exit Sub
    Rem Kodlarınız...
    Rem Kodlarınız...
    Rem Kodlarınız...
    Rem Kodlarınız...
    Rem Kodlarınız...
End Sub

 

[Karamanli.70]

Muzaffer Ali Hocam ve Korhan Ayhan Hocam Çok teşekkür ederim emeğiniz için.
Benim Kod bloğum aşağıdaki şekilde ve "T" hücresine tıklayınca istenen bilgiler getiriyorum. Ancak her seferinde T hücresine tıklamak yerine bu bilgileri personel kaydet butonuna yada değiştir butonuna atama yapabilirmiyim?

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim s As Long

Cells.Interior.ColorIndex = xlColorIndexNone
ActiveCell.EntireColumn.Interior.ColorIndex = 19 'Sütun Rengi
ActiveCell.EntireRow.Interior.ColorIndex = 17 ' Satır Rengi
ActiveCell.Cells.Interior.ColorIndex = 4 ' Hücre Rengİ

On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("SABİTLER")
son1 = s1.Range("B65536").End(xlUp).Row
son2 = s1.Range("H65536").End(xlUp).Row
son3 = s1.Range("O65536").End(xlUp).Row

sat = Target.Row
Süt = Target.Column

If sat >= 2 And Süt = 20 And Cells(sat, Süt) <> "" Then

aranan1 = Cells(sat, 8): bulunanno1 = 0
aranan2 = Cells(sat, 11): bulunanno2 = 0
aranan3 = Cells(sat, 13): bulunanno3 = 0
aranan4 = Cells(sat, 15): bulunanno4 = 0

'UNVAN VE BRANS ARAMASI
bulunanno1 = WorksheetFunction.Match(aranan1, s1.Range("B1:B" & son1), 0)
If bulunanno1 >= 1 Then
Cells(sat, 6) = s1.Cells(bulunanno1, 3)
Cells(sat, 7) = s1.Cells(bulunanno1, 4)

'FİİLİ KURUM ARAMASI
bulunanno2 = WorksheetFunction.Match(aranan2, s1.Range("H1:H" & son2), 0)
If bulunanno2 >= 1 Then
Cells(sat, 10) = s1.Cells(bulunanno2, 9)

'KADRO KURUM ARAMASI
bulunanno3 = WorksheetFunction.Match(aranan3, s1.Range("H1:H" & son2), 0)
If bulunanno3 >= 1 Then
Cells(sat, 12) = s1.Cells(bulunanno3, 9)

bulunanno4 = WorksheetFunction.Match(aranan4, s1.Range("H1:H" & son2), 0)
If bulunanno4 >= 1 Then
Cells(sat, 14) = s1.Cells(bulunanno4, 9)

End If
End If
End If
End If
End If

If Intersect(Target, Range("t3:t65536")) Is Nothing Then Exit Sub
For i = 3 To Range("t65536").End(3).Row
If Cells(i, 20).Value = "" Then
Cells(i, 1).Value = ""
Else
s = s + 1
Cells(i, 1).Value = s
End If
Next i

End Sub

 

[Muzaffer Ali]

Bu kod ile yapabilirsiniz.

Private Sub CommandButton1_Click()
    Worksheet_SelectionChange ActiveCell
End Sub

 

[Karamanli.70]

Muzaffer Ali hocam ilginiz için teşekkür ederim.

Private Sub CommandButton17_Click()
Worksheet_SelectionChange ActiveCell
End Sub

tanımladım ancak hata verdi

 

[Muzaffer Ali]

Hangi satırda ve nasıl bir hata verdi.

 

[Karamanli.70]

userform üzerine eklediğim command buttonda hata verdi. Worksheet_SelectionChange kodlarının olduğu sheets de de var orda da denedim olmadı

 

[Muzaffer Ali]

Dosyayı ekleyin kontrol edelim.

 

[Karamanli.70]

Muzaffer Ali Hocam Örnek dosyayı ekledim.

 

[Muzaffer Ali]

Per_List sayfasındaki listenin tamamını hazırladıktan sonra Sütun3 ve Sütun4 değerlerinin tamamını bir butona basarak mı gelmesini istiyorsunuz?
Yoksa her satır için butona basıp tek tek gelmesini mi istiyorsunuz?

 

[Muzaffer Ali]

Butona basarak tamamının gelmesi için aşağıdaki kodu kullanın.

Private Sub CommandButton1_Click()
    Dim Bak As Long, Say As Long
    Dim syfSabitler As Worksheet, syfPer_List As Worksheet
    Dim Bul As Range
    Set syfSabitler = ThisWorkbook.Worksheets("SABİTLER")
    Say = syfSabitler.Range("B" & Rows.Count).End(xlUp).Row
    For Bak = 3 To Range("E" & Rows.Count).End(xlUp).Row
        Set Bul = syfSabitler.Range("B1:B" & Say).Find(Cells(Bak, "E"), Lookat:=xlWhole)
        If Bul Is Nothing Then
            MsgBox "Personel ünvanı '" & Cells(Bak, "E") & "' bulunamadı."
            Cells(Bak, "A").Value = ""
            Cells(Bak, "C").Value = ""
            Cells(Bak, "D").Value = ""
        Else
            Cells(Bak, "A").Value = Bak - 2
            Cells(Bak, "C").Value = syfSabitler.Cells(Bul.Row, "C")
            Cells(Bak, "D").Value = syfSabitler.Cells(Bul.Row, "D")
        End If
    Next
    MsgBox "Tamamlandı."
End Sub

 

[Karamanli.70]

Muzaffer Ali Hocam Butona basarak tamamının gelmesini istiyordum hemen deniyorum.

 

[Karamanli.70]

Muzaffer Ali Hocam çok teşekkür ederim. Bu kodu biraz daha geliştirip personellerin kurumlarına göre kurum kodlarını da getireceğim. Elinize sağlık

 

[Karamanli.70]

Peki her satır için butona basıp tek tek gelmesini nasıl yapardık

 

[Muzaffer Ali]

Aşağıdaki kod ile olur.
Yukarıdaki kodda hata vardı onu da düzelttim.

Private Sub CommandButton2_Click()
    Dim Say As Long
    Dim syfSabitler As Worksheet
    Dim Bul As Range
    Set syfSabitler = ThisWorkbook.Worksheets("SABİTLER")
    Say = syfSabitler.Range("B" & Rows.Count).End(xlUp).Row
    Set Bul = syfSabitler.Range("B1:B" & Say).Find(Cells(ActiveCell.Row, "E"), Lookat:=xlWhole)
    If Bul Is Nothing Then
        MsgBox "Personel ünvanı '" & Cells(ActiveCell.Row, "E") & "' bulunamadı."
    Else
        Cells(ActiveCell.Row, "A").Value = ActiveCell.Row - 2
        Cells(ActiveCell.Row, "C").Value = syfSabitler.Cells(Bul.Row, "C")
        Cells(ActiveCell.Row, "D").Value = syfSabitler.Cells(Bul.Row, "D")
    End If
End Sub

 

[Karamanli.70]

Teşekkür ederim İlginiz ve Emeğiniz için Muzaffer Bey çok sağ olun çok makbule geçti.