Makro ile seçilen 3 sütunda mükerrer kaydı önlemek

[unur]

Arkadaşlar Kandiliniz Mübarek olsun.

Başlıktan da anlaşılacağı üzere makro ile seçilen 3 sütünda (hangi ay seçilmiş ise o ay) mükerer kaydı önlemek için kodlarda revizyon yapılabilirmi?

Yardımcı olacak arkadaşlara şimdiden teşekkürler.

 

[Husgvarna]

Arkadaşlar Kandiliniz Mübarek olsun.

Başlıktan da anlaşılacağı üzere makro ile seçilen 3 sütünda (hangi ay seçilmiş ise o ay) mükerer kaydı önlemek için kodlarda revizyon yapılabilirmi?

Yardımcı olacak arkadaşlara şimdiden teşekkürler.

Aşağıdaki gibi deneyin.

 Private Sub Worksheet_Change(ByVal Target As Range)
Dim sut As Byte
If Intersect(Target, [c2]) Is Nothing Then Exit Sub
Cells.EntireColumn.Hidden = False
    For sut = 4 To 39
        If Not Cells(4, sut).Value Like [c2].Value Then
            Cells(4, sut).EntireColumn.Hidden = True
        End If
    Next
say = WorksheetFunction.CountIf(Range("d4:ar4"), Target)
Set a = Range("c4:ar4").Find(what:=Target)
If Not a Is Nothing Then
For Each s In Range(Cells(5, a.Column), Cells(38, a.Column + say - 1))
If WorksheetFunction.CountIf(Range(Cells(s.Row, a.Column), Cells(38, a.Column + say - 1)), s) > 1 Then
Set a2 = Range(Cells(s.Row, a.Column), Cells(38, a.Column + say - 1)).Find(what:=s)
If Not a2 Is Nothing Then
a2.Interior.ColorIndex = 3

'..........................veya
  [COLOR="Red"] 'a2.Value = ""[/COLOR]
'...........................

End If
End If
Next
End If
End Sub

 

[unur]

Aşağıdaki gibi deneyin.


'..........................veya
'a2.Value = ""
'...........................

End Sub [/CODE]

Sayın husgvarna Çok teşekkürler;
Bu boşluğa önceki kodları mı yerleştirmem lazım makro ve kodlardan pek anlamıyorumda kusura bakmayın.
Renklendirme yapmıyor ve herhangi bir uyarı vermiyor benmi yanlış yapıyorum uygulamada acaba

 

[Husgvarna]

Renklendirme yapmıyor ve herhangi bir uyarı vermiyor benmi yanlış yapıyorum uygulamada acaba

Merhaba.
Eklediğiniz dosyada mükerrer gün girişi olmadığı için.

Not: Mükerrer verilerin eklenmesini engellemek için her ay için ayrı sayfa daha iyi olmazmı?

 

[unur]

Emekleriniz için Teşekkürler husgvarna, her ay için ayrı ayrı sayfa işimi görmüyor 12 aylık bir belge eğer mevcut haliyle yapabilirsek mükemmel bir şey olacak.Kodlardan anlamıyorum ancak mantık olarak yazılan kod C2 de seçilen aya uygulanabilirmi bilmem öyle bir değişken kod tanımlanabilirmi?
Örn: Mükerer kaayıt için yazılan kod c2 de aralık seçili ise aralık sutunları için eylül seçili ise eylül için gibi.
Yardımlarınız için teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sut As Byte
If Intersect(Target, [c2]) Is Nothing Then Exit Sub
Cells.EntireColumn.Hidden = False
For sut = 4 To 39
If Not Cells(4, sut).Value Like [c2].Value Then
Cells(4, sut).EntireColumn.Hidden = True
End If
Next
End Sub

 

[unur]

Güncellemek için

Emekleriniz için Teşekkürler husgvarna, her ay için ayrı ayrı sayfa işimi görmüyor 12 aylık bir belge eğer mevcut haliyle yapabilirsek mükemmel bir şey olacak.Kodlardan anlamıyorum ancak mantık olarak yazılan kod C2 de seçilen aya uygulanabilirmi bilmem öyle bir değişken kod tanımlanabilirmi?
Örn: Mükerer kaayıt için yazılan kod c2 de aralık seçili ise aralık sutunları için eylül seçili ise eylül için gibi.
Yardımlarınız için teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sut As Byte
If Intersect(Target, [c2]) Is Nothing Then Exit Sub
Cells.EntireColumn.Hidden = False
For sut = 4 To 39
If Not Cells(4, sut).Value Like [c2].Value Then
Cells(4, sut).EntireColumn.Hidden = True
End If
Next
End Sub

 

[Husgvarna]

Merhaba.
Seçilen 3 sütunda aynı günün tekrar girilmesini engellemek istiyorsanız şöyle deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sut As Byte
If Intersect(Target, [c2]) Is Nothing Then GoTo s
Cells.EntireColumn.Hidden = False
    For sut = 4 To 39
        If Not Cells(4, sut).Value Like [c2].Value Then
           If Cells(4, sut).Value = [c2].Value Then
          x = Cells(4, sut).Address
           End If
            Cells(4, sut).EntireColumn.Hidden = True
        End If
    Next
s:
For x = 4 To 39
If Cells(4, x).Value = [c2].Value Then Exit For
Next
If Intersect(Target, Range(Cells(4, x), Cells(40, x + 2)), Target.Cells) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range(Cells(4, x), Cells(40, x + 2)), Target.Value) > 1 Then
MsgBox "mükerrer kayıt"
Target.Cells.Select
End If
End Sub

 

[unur]

Sayın hugsvarna Allah razı olsun. Çok Teşekkürler. Emeklerinize sağlık.