Merhaba
Elimde bulunan aşağıdaki makro kod düzeneğinde ufak bir ekleme yapmak istiyorum. fakat bilgim gereği biraz kurcalasam da beceremedim siz üstadlarım yardımını rica ederim. Bu kod düzeneğinde H sütununda belirli bir hücreye veri girdiğim zaman eğer aynı sütunda aynı veriden varsa msgbox olarak çıkan uyarı mesajında benzer verilerin olduğu hücre adreslerini yazıyor.
Ben burada şunu istiyorum. veri girişi yaptığım hücrede değilde aslında önceden varolan hücredeki verinin bulunduğu satırdaki C sütunu içerisinde yazan veri bilgisini de msgbox içerisinde yazsın istiyorum
Bilgi ve yardımlarınızı rica ederim
Örnek dosya link İndir
https://dosya.co/1yino0q5szn9/ornek.rar.html
Elimde bulunan aşağıdaki makro kod düzeneğinde ufak bir ekleme yapmak istiyorum. fakat bilgim gereği biraz kurcalasam da beceremedim siz üstadlarım yardımını rica ederim. Bu kod düzeneğinde H sütununda belirli bir hücreye veri girdiğim zaman eğer aynı sütunda aynı veriden varsa msgbox olarak çıkan uyarı mesajında benzer verilerin olduğu hücre adreslerini yazıyor.
Ben burada şunu istiyorum. veri girişi yaptığım hücrede değilde aslında önceden varolan hücredeki verinin bulunduğu satırdaki C sütunu içerisinde yazan veri bilgisini de msgbox içerisinde yazsın istiyorum
Bilgi ve yardımlarınızı rica ederim
Örnek dosya link İndir
https://dosya.co/1yino0q5szn9/ornek.rar.html
Kod:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Local Error GoTo cikis
Dim adres As String
If Target.Row = 1 Then Exit Sub
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim myDataRng As Range
Dim cell As Range
Set myDataRng = Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row)
For Each cell In myDataRng
cell.Offset(0, 0).Font.Color = vbBlack
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
cell.Offset(0, 0).Font.Color = vbRed
adres = adres & vbLf & cell.Address & " Numaralı hücre"
End If
Next cell
Set myDataRng = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
If Intersect(Target, Range("H:H")) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("H:H"), Target) > 1 Then
If adres <> "" Then MsgBox "Aşağıda belirtilen hücrelerde benzer veri girişleri yapılmıştır. Düzeltiniz.!" & adres, vbCritical, "Benzer Veri Girişi Uyarısı"
Target = ""
End If
End Sub