Hücrelere açıklama ekleme kodunda değişiklik

[Yesilyurtlu]

Option Explicit
Dim Eski_Veri As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Hücre As Range, Açıklama As String, WF As WorksheetFunction

Set WF = WorksheetFunction
Set Hücre = Target

On Error GoTo Son

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

With Hücre
If .Value = "" Then GoTo Son
If .Value = Eski_Veri Then GoTo Son

If Eski_Veri = Empty Then
Açıklama = "Boş Hücre !" & WF.Rept(" ", 35 - Len("Boş Hücre !"))
Else
Açıklama = Eski_Veri & WF.Rept(" ", 35 - Len(Eski_Veri))
End If

If Not .Comment Is Nothing Then
.Comment.Text Text:=.Comment.Text & Chr(10) & Açıklama & Now
With .Comment.Shape
.Left = .Left
.Top = .Top
.Width = 250
.Height = .Height + 12.5
End With
Else
.AddComment
.Comment.Text Text:=.Comment.Text & Açıklama & Now
With .Comment.Shape
.Left = .Left
.Top = .Top
.Width = 250
.Height = 12.5
End With
End If

.Comment.Visible = True
End With
Son:
Set WF = Nothing
Set Hücre = Nothing
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Eski_Veri = Target.Value
End Sub



Kod Korhan Ustama ait koddur. Siteden alınmıştır.
Yukarıdaki kod bütün boş hücrelere açıklama eklemekte. Sadece E16:E37 hücrelerinde çalışması için yardımcı olabilir misiniz?

 

[İhsan Tank]

Merhaba
Bo şekilde deneyin

Option Explicit
Dim Eski_Veri As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("E16:E37")) Is Nothing Then Exit Sub
Dim Hücre As Range, Açıklama As String, WF As WorksheetFunction

Set WF = WorksheetFunction
Set Hücre = Target

On Error GoTo Son

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

With Hücre
If .Value = "" Then GoTo Son
If .Value = Eski_Veri Then GoTo Son

If Eski_Veri = Empty Then
Açıklama = "Boş Hücre !" & WF.Rept(" ", 35 - Len("Boş Hücre !"))
Else
Açıklama = Eski_Veri & WF.Rept(" ", 35 - Len(Eski_Veri))
End If

If Not .Comment Is Nothing Then
.Comment.Text Text:=.Comment.Text & Chr(10) & Açıklama & Now
With .Comment.Shape
.Left = .Left
.Top = .Top
.Width = 250
.Height = .Height + 12.5
End With
Else
.AddComment
.Comment.Text Text:=.Comment.Text & Açıklama & Now
With .Comment.Shape
.Left = .Left
.Top = .Top
.Width = 250
.Height = 12.5
End With
End If

.Comment.Visible = True
End With
Son:
Set WF = Nothing
Set Hücre = Nothing
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("E16:E37")) Is Nothing Then Exit Sub
Eski_Veri = Target.Value
End Sub

 

[Yesilyurtlu]

İhsan Abi Eline Sağlık
Allah Razı Olsun

 

[İhsan Tank]

İhsan Abi Eline Sağlık
Allah Razı Olsun

Kolay Gelsin
:keyif: