- Katılım
- 30 Mart 2008
- Mesajlar
- 280
- Excel Vers. ve Dili
- Microsoft Office Excel 2003, Türkçe
Ekte gönderdiğim dosyada C sutununa tc kimlik numarası, K sutununa şube kodu, L sutununa hesap numarası ve M sutununa da hesap uzantısı girilmekte.
Sayın Korhan Ayhan hocamın yazmış olduğu kod sayesinde şube kodu, hesap numarası ve hesap uzantısı veri girişinde mükerrer girilince daha önce girilmiş aynı hesap bilgilerinin hangi satırda olduğunu vermekte ve benim isteğim gibi çalışmakta. Bir hesap numarası birden fazla girilebilir. Lakin kopyala yapıştır yapılınca kod bu özelliğini kullanamakta. İlgili kod aşağıda.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim SAY As Long
Dim BUL As Range
Dim ADRES As String
Dim SATIR As String
Dim ONAY As Variant
If Intersect(Target, [k2:m65536]) Is Nothing Then Exit Sub
If IsEmpty(Target) Or InStr(1, Target.Address, ":") <> 0 Then Exit Sub
If Cells(Target.Row, "K") <> "" And Cells(Target.Row, "L") <> "" And Cells(Target.Row, "M") <> "" Then
SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
If SAY > 1 Then
Set BUL = Range(Cells(2, Target.Column), Cells(Target.Row - 1, Target.Column)).Find(Target)
If Not BUL Is Nothing Then
ADRES = BUL.Address
Do
If Cells(Target.Row, "K") = Cells(BUL.Row, "K") And Cells(Target.Row, "L") = Cells(BUL.Row, "L") And Cells(Target.Row, "M") = Cells(BUL.Row, "M") Then
SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
End If
Set BUL = Range(Cells(2, Target.Column), Cells(Target.Row - 1, Target.Column)).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> ADRES
GoTo UYARI
End If: End If: End If
GoTo SON
UYARI:
If SATIR = "" Then GoTo SON
ONAY = MsgBox("Bu kayıt daha önce aşağıdaki satırlarda girilmiştir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "İşleme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "DİKKAT !")
If ONAY = vbNo Then
Cells(Target.Row, "K") = ""
Cells(Target.Row, "L") = ""
Cells(Target.Row, "M") = ""
Cells(Target.Row, 11).Select
Exit Sub: End If
Cells(Target.Row, 14).Select
SON:
End Sub
Yardımcı olunmasını istediğim konu:
*Hesap bilgileriyle alakalı kodun veri girişindeki gibi kopyala yapıştırda da çalışması.
İlgilenen herkese şimdiden teşekkürler. İyi çalışmalar.
Sayın Korhan Ayhan hocamın yazmış olduğu kod sayesinde şube kodu, hesap numarası ve hesap uzantısı veri girişinde mükerrer girilince daha önce girilmiş aynı hesap bilgilerinin hangi satırda olduğunu vermekte ve benim isteğim gibi çalışmakta. Bir hesap numarası birden fazla girilebilir. Lakin kopyala yapıştır yapılınca kod bu özelliğini kullanamakta. İlgili kod aşağıda.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim SAY As Long
Dim BUL As Range
Dim ADRES As String
Dim SATIR As String
Dim ONAY As Variant
If Intersect(Target, [k2:m65536]) Is Nothing Then Exit Sub
If IsEmpty(Target) Or InStr(1, Target.Address, ":") <> 0 Then Exit Sub
If Cells(Target.Row, "K") <> "" And Cells(Target.Row, "L") <> "" And Cells(Target.Row, "M") <> "" Then
SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
If SAY > 1 Then
Set BUL = Range(Cells(2, Target.Column), Cells(Target.Row - 1, Target.Column)).Find(Target)
If Not BUL Is Nothing Then
ADRES = BUL.Address
Do
If Cells(Target.Row, "K") = Cells(BUL.Row, "K") And Cells(Target.Row, "L") = Cells(BUL.Row, "L") And Cells(Target.Row, "M") = Cells(BUL.Row, "M") Then
SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
End If
Set BUL = Range(Cells(2, Target.Column), Cells(Target.Row - 1, Target.Column)).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> ADRES
GoTo UYARI
End If: End If: End If
GoTo SON
UYARI:
If SATIR = "" Then GoTo SON
ONAY = MsgBox("Bu kayıt daha önce aşağıdaki satırlarda girilmiştir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "İşleme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "DİKKAT !")
If ONAY = vbNo Then
Cells(Target.Row, "K") = ""
Cells(Target.Row, "L") = ""
Cells(Target.Row, "M") = ""
Cells(Target.Row, 11).Select
Exit Sub: End If
Cells(Target.Row, 14).Select
SON:
End Sub
Yardımcı olunmasını istediğim konu:
*Hesap bilgileriyle alakalı kodun veri girişindeki gibi kopyala yapıştırda da çalışması.
İlgilenen herkese şimdiden teşekkürler. İyi çalışmalar.
Ekli dosyalar
-
25.5 KB Görüntüleme: 25
Son düzenleme: