Oldumu bilmiyorum yinede bir deneyiniz.
Yaptıkları şunlar;
Ocak ayı için kodu ekledim.
F7:FAJ son satır aralığında tıklayınca kod çalışır.
Eğer tek hücre seçilirse ve çoklu hücre seçilirse ılarak ayarladım.
Tek hücre seçilirse Açıklama varsa o açıklama inputboxa gelir çok seçimde yapmadım mantıkende olmaz bence.
Eğer inputbox boşsa ve çıkan mesaj evet seçilirse seçilen hücrelerdeki açıklamalar silinir.
Boş değilse seçilenlerin hepsine inputboxttaki ne ise o yazdırılır açıklama olarak.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Açıklama_Ekleme As Comment, aa As String
Dim strText, hucre As Range, hucre2 As Range, son As Long
son = ActiveSheet.Range("Aj" & Rows.Count).End(3).Row
If Target.Row < 7 Then Exit Sub
If Target.Row > son Then Exit Sub
If Target.Column < 7 Then Exit Sub
If Target.Column > 36 Then Exit Sub
If Cells(Target.Row, 2).Value <> "" And Len(Cells(Target.Row, 2).Value + 0) <> 6 Then Exit Sub
Set Açıklama_Ekleme = Target.Comment
If Not Açıklama_Ekleme Is Nothing Then
strText = Application.InputBox("Eklenecek olan mesajı aşağıya yazınız.", "Açıklama_Ekleme", Target.Comment.text, , , , 2)
Else
strText = Application.InputBox("Eklenecek olan mesajı aşağıya yazınız.", "Açıklama_Ekleme", "Açıklama Ekler", , , , 2)
End If
If strText = False Then Exit Sub
'Eger inputbox bossa
If strText = "" Then
'eger inputbox bossa ve msaj kuutundan evet secilirse
If MsgBox("Secilen aciklamalar silinsin mi?", vbQuestion + vbYesNo) = vbYes Then
'eger tek hücre secilmisse
If Target.Cells.Count = 1 Then
sil Target
'eger birden fazla hücre secilmisse
Else
For Each hucre2 In Selection
sil hucre2
Next
End If
End If
'eger inputbox bos degilse
Else
'eger tek hücre secilmisse
If Target.Cells.Count = 1 Then
ekle Target, strText
'eger birden fazla hücre secilmisse
Else
For Each hucre2 In Selection
ekle hucre2, strText
Next
End If
End If
End Sub
Sub ekle(hucre As Range, metin)
hucre.AddComment
Set Açıklama_Ekleme = hucre.Comment
With Açıklama_Ekleme
.text text:=metin
With .Shape.TextFrame.Characters.Font
.Name = "Arial"
.Size = 8
.Bold = False
End With
End With
End Sub
[vb]
Sub sil(hucre As Range)
On Error Resume Next
hucre.Comment.Delete
On Error GoTo 0
End Sub
Puantaj YILDIZ1 comment son.rar
(Dosya Boyutu: 461,63 KB | İndirme Sayısı: 2)