Açıklama ekleme

[fehdur]

Aşağıdaki kod ile Textbox2'ye yazılanları açıklama olarak comboboxdaki ismin bulunduğu excel ekliyorum ama "A" sütununda yer alan isimler içinde çok sayıda aynı isim var dolayısıyla açıklama ilk gelen isme ekleniyor oysa benim yapmak istediğim istediğim satır ve sütuna açıklama eklemek.Başka deyişle"Textbox1'deki tarihe ve comboboxdaki isime göre kriter oluşturup textbox2'ye yazılanları istenen hücreye açıklama olarak eklemek.. B sütununda tarihler var.Örnek dosyayı aşağıda paylaşıyorum.
a = Sheets("Takip").TextBox2
If a = "" Then Exit Sub
On Error Resume Next
Sheets("Takip").Columns(1).Find(ComboBox1).AddComment
Sheets("Takip").Columns(1).Find(ComboBox1).Comment.Text a
MsgBox "kayıt yapılmıştır"

 

[Ömer]

Merhaba,

Deneyiniz.

Private Sub CommandButton2_Click()

    Dim trh As Date, ara As String, deg As String, c As Range, Adr As String

    trh = TextBox1
    ara = ComboBox1
    deg = TextBox2
    
    If deg = "" Then
        MsgBox "Önce Açıklama Girin", vbInformation
        Exit Sub
    End If

    Set c = [A:A].Find(ara, , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If Cells(c.Row, "B") = trh Then
                Cells(c.Row, "A").ClearComments
                Cells(c.Row, "A").AddComment
                Cells(c.Row, "A").Comment.Text Text:=""
                Cells(c.Row, "A").Comment.Text Text:=deg
                s = 1
            End If
            Set c = [A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

    If s = 1 Then
        MsgBox "Açıklama Eklendi", vbInformation
    Else
        MsgBox "Veri Bulunamadı", vbInformation
    End If
    
End Sub

 

[fehdur]

Kod için teşekkürler.Bir de comboboxa ve textbox1'e girdğimiz değerlere göre aranan açıklamayı textbox2'de nasıl gösterebiliriz.Yani ben aranan kişinin ismini ve tarihi gireyim daha sonra o açıklamayı textbox2'de göreyim.

 

[fehdur]

Merhaba,

Deneyiniz.

Private Sub CommandButton2_Click()

    Dim trh As Date, ara As String, deg As String, c As Range, Adr As String

    trh = TextBox1
    ara = ComboBox1
    deg = TextBox2
   
    If deg = "" Then
        MsgBox "Önce Açıklama Girin", vbInformation
        Exit Sub
    End If

    Set c = [A:A].Find(ara, , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If Cells(c.Row, "B") = trh Then
                Cells(c.Row, "A").ClearComments
                Cells(c.Row, "A").AddComment
                Cells(c.Row, "A").Comment.Text Text:=""
                Cells(c.Row, "A").Comment.Text Text:=deg
                s = 1
            End If
            Set c = [A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

    If s = 1 Then
        MsgBox "Açıklama Eklendi", vbInformation
    Else
        MsgBox "Veri Bulunamadı", vbInformation
    End If
   
End Sub

Kod için teşekkürler.Yalnız comboboxa ve textbox1'e girdğimiz değerlere göre aranan açıklamayı textbox2'de nasıl görebiliriz.Yani ben aranan kişinin ismini ve tarihi gireyim daha sonra o açıklamayı textbox2'de göreyim.

 

[Ömer]

Yeni bir buton ekleyip deneyiniz.CommandButton3 düşünüldü.

Private Sub CommandButton3_Click()
    
    Dim trh As Date, ara As String, deg As String, c As Range, Adr As String

    trh = TextBox1
    ara = ComboBox1

    Set c = [A:A].Find(ara, , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If Cells(c.Row, "B") = trh Then
                deg = deg & Chr(10) & Cells(c.Row, "A").Comment.Text
            End If
            Set c = [A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
    If deg <> "" Then
        MsgBox "Açıklamalar:" & vbLf & deg, vbInformation
    End If
    
End Sub

 

[seddur]

kodu uyarlayamıyorum.İlk verdiğiniz kod ile birlikte çalışma yapıyorum.Kodu checkbox click olayına yazıyorum.Checkbox true iken açıklamayı gösterecek False ikende kaydet yapacak.İlk verdiğiniz kod da "S" değerini anlayamadım kod çalıştığında VERİ BULUNAMADI hatası veriyor,çözemedimAçıklama gösterme kodu olarak kullandığım kodu aşağıda paylaşıyorum.Textbox2'de isim,textbox3'de tarih varTextbox8 'de açıklama gösteriliyor..Yardımcı olursanız sevinirim.

If TextBox2 = "" Or TextBox3 = "" Then
MsgBox "Lütfen hasta seçimi ile birlikte tarih giriniz"
Exit Sub
End If
For a = 15 To [A65536].End(xlUp).Row
If Cells(a, 1) = TextBox2 And CDate(Cells(a, 2)) = CDate(TextBox3) Then
On Error Resume Next
TextBox8 = ""
TextBox8 = Cells(a, 1).Comment.Text

End If
Next a

 

[Ömer]

Eklediğiniz örnek dosyaya göre:
CommandButton2'un eski kodları silip aşağıdakileri ekleyin.

Private Sub CommandButton2_Click()
    If CommandButton2.Caption = "açıklama ekle" Then
        Call Aciklama_Ekle
        CommandButton2.Caption = "açıklama göster"
    Else
        Call Aciklama_Goster
        CommandButton2.Caption = "açıklama ekle"
    End If
End Sub

Private Sub Aciklama_Ekle()

    Dim trh As Date, ara As String, deg As String, c As Range, Adr As String

    trh = TextBox1
    ara = ComboBox1
    deg = TextBox2
  
    If deg = "" Then
        MsgBox "Önce Açıklama Girin", vbInformation
        Exit Sub
    End If

    Set c = [A:A].Find(ara, , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If Cells(c.Row, "B") = trh Then
                Cells(c.Row, "A").ClearComments
                Cells(c.Row, "A").AddComment
                Cells(c.Row, "A").Comment.Text Text:=""
                Cells(c.Row, "A").Comment.Text Text:=deg
                s = 1
            End If
            Set c = [A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

    If s = 1 Then
        MsgBox "Açıklama Eklendi", vbInformation
    Else
        MsgBox "Veri Bulunamadı", vbInformation
    End If
  
End Sub

Private Sub Aciklama_Goster()
  
    Dim trh As Date, ara As String, deg As String, c As Range, Adr As String

    trh = TextBox1
    ara = ComboBox1
  
    On Error GoTo atla
    Set c = [A:A].Find(ara, , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If Cells(c.Row, "B") = trh Then
                 deg = deg & Chr(10) & Cells(c.Row, "A").Comment.Text
            End If
            Set c = [A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
  
    If deg <> "" Then
        MsgBox "Açıklamalar:" & vbLf & deg, vbInformation
    End If
    Exit Sub
atla:
    MsgBox "Bulunan hücrede açıklama yok", vbInformation

End Sub