Mesaj Kutusu Hakkında

[konas06]

İyi geceler,
mesaj kutusu ile ilgili bir çalışma yapmam gerekiyor, örneğin a2 hücresine girdiğim değere göre bir mesaj kutusunda bu değer için belirlenmiş notları getirmek gerekiyor.
Yardımlarınız için şimdiden çok teşekkür ederim.
Selamlar.

 

[Necdet]

Merhaba,

Örnek verebilir misiniz? Ne tür mesaj örneğin?

 

[Orion1]

Dosyanız ektedir.
Kod lar çalışma sayfasının kod modülünde.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim k As Range, sh As Worksheet, sut As Integer, i As Integer
If Intersect(Target, [A2:A65536]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Set sh = Sheets("BİLGİLER")
Set k = sh.Range("A2:A65536").Find(Target.Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    sut = sh.Cells(1, "IV").End(xlToLeft).Column
    UserForm1.ListView1.View = lvwReport
    UserForm1.ListView1.Gridlines = True
    UserForm1.ListView1.FullRowSelect = True
    UserForm1.ListView1.Font.Bold = True
    UserForm1.ListView1.ColumnHeaders.Add , , "NOTLAR", 150
    UserForm1.ListView1.ColumnHeaders.Add , , "DÜŞÜNCELER", 250
    UserForm1.ListView1.ListItems.Add , , sh.Cells(k.Row, 1).Value
    UserForm1.ListView1.ListItems(1).ForeColor = RGB(120, 150, 50)
    For i = 2 To sut
        UserForm1.ListView1.ListItems.Add , , sh.Cells(1, i).Value
        UserForm1.ListView1.ListItems(i).ListSubItems.Add , , sh.Cells(k.Row, i).Value
        If i Mod 2 = 0 Then
            UserForm1.ListView1.ListItems(i).ForeColor = vbBlue
            UserForm1.ListView1.ListItems(i).ListSubItems(1).ForeColor = vbBlue
            Else
            UserForm1.ListView1.ListItems(i).ForeColor = vbRed
            UserForm1.ListView1.ListItems(i).ListSubItems(1).ForeColor = vbRed
        End If
    Next i
    UserForm1.ListView1.ListItems(1).Selected = False
    UserForm1.Show
End If
End Sub

 

[konas06]

Dosyanız ektedir.
Kod lar çalışma sayfasının kod modülünde.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim k As Range, sh As Worksheet, sut As Integer, i As Integer
If Intersect(Target, [A2:A65536]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Set sh = Sheets("BİLGİLER")
Set k = sh.Range("A2:A65536").Find(Target.Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    sut = sh.Cells(1, "IV").End(xlToLeft).Column
    UserForm1.ListView1.View = lvwReport
    UserForm1.ListView1.Gridlines = True
    UserForm1.ListView1.FullRowSelect = True
    UserForm1.ListView1.ColumnHeaders.Add , , "FİRMA", 150
    UserForm1.ListView1.ColumnHeaders.Add , , "DÜŞÜNCELER", 250
    UserForm1.ListView1.ListItems.Add , , sh.Cells(k.Row, 1).Value
    For i = 2 To sut
        UserForm1.ListView1.ListItems.Add , , sh.Cells(1, i).Value
        UserForm1.ListView1.ListItems(i).ListSubItems.Add , , sh.Cells(k.Row, i).Value
    Next i
    UserForm1.Show
End If
End Sub

Hocam çok teşekkür ederim.
İyiki varsınız.
Tüm bizden bilgilerini esirgemeyen herkese çok teşekkürler.
Saygılarımla.

 

[Orion1]

Hocam çok teşekkür ederim.
İyiki varsınız.
Tüm bizden bilgilerini esirgemeyen herkese çok teşekkürler.
Saygılarımla.

Rica ederim.
İyi çalışmalar.

 

[Orion1]

Bir satırın fontunun rengini kırmızı ve bold diğer satırın rengini mavi ve bold yaptım.Renklendi.
Şimdi dahada güzel oldu.
Dosyayı 3 numaralı mesajdan indirebilirisiniz..

 

[Necdet]

Merhaba,

Alternatif olsun
Aşağıdaki kodlar ilgili sayfanın kod bölümünde olmalı.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target.Row < 2 Then Exit Sub
    Dim Bul As Range
    
    Set Bul = Sheets("BİLGİLER").[A:A].Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
    Shapes("Aciklama").Select
    If Not Bul Is Nothing Then
        Selection.Formula = "BİLGİLER!A" & Bul.Row & ":H" & Bul.Row
    Else
         Selection.Formula = "BİLGİLER!A1:H1"
    End If
    
    Shapes("Aciklama").Top = Target.Offset(2, 0).Top
    Shapes("Aciklama").Left = Target.Offset(2, 0).Left
Son:
End Sub

 

[konas06]

Evren bey, Necdet bey çok teşekkür ederim.
Selamlar.