Çözüldü Koşula Göre Mesaj Kutusu Uyarısı Verdirme

[ckaval89]

Üstatlar merhaba,

Forumu ve tüm interneti çok araştırdım fakat tam olarak istediğim bilgiye malesef erişemedim.

Eklemiş olduğum örnek dosyada iki sütunda da veri doğrulama ile tarih seçimi yapılıyor. İstediğim şey ise ikinci sütunda tarih seçildiğinde, eğer seçilen tarih ilk sütunda aynı satırdaki tarihten küçükse message box ile " Bu tarih ilk tarihten küçük olamaz" şeklinde bir uyarı verdirmek.

Desteğiniz için şimdiden çok teşekkür ederim.

Saygılarımla,

 

[Muzaffer Ali]

Merhaba.

Sheet1'in kod kısmına kopyalayın. Kodlar otomatik çalışacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A:B")) Is Nothing And Cells(Target.Row, "A") <> "" And Cells(Target.Row, "B") <> "" Then
        If Cells(Target.Row, "A") > Cells(Target.Row, "B") Then
            MsgBox "2. tarih 1. tarihten küçük olamaz.", vbCritical
            Target = Empty
        End If
    End If
End Sub

 

[ckaval89]

Muzaffer Bey merhaba,

Dosyamdaki aynı çalışma sayfasında aşağıdaki kod olduğu için compile error veriyor. Desteğiniz için çok teşekkür ederim.

Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To allow multiple selections in a Drop Down List in Excel (without repetition)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 3 Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub


Bu durumu nasıl çözebilirim?
Saygılarımla,

 

[Muzaffer Ali]

Deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To allow multiple selections in a Drop Down List in Excel (without repetition)
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = True
    
    On Error GoTo Exitsub
    
    If Not Intersect(Target, Range("A:B")) Is Nothing And Cells(Target.Row, "A") <> "" And Cells(Target.Row, "B") <> "" Then
        If Cells(Target.Row, "A") > Cells(Target.Row, "B") Then
            MsgBox "2. tarih 1. tarihten küçük olamaz.", vbCritical
            Target = Empty
        End If
    ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else
            If Target.Value = "" Then GoTo Exitsub Else
                Application.EnableEvents = False
                Newvalue = Target.Value
                Application.Undo
                Oldvalue = Target.Value
                If Oldvalue = "" Then
                    Target.Value = Newvalue
                Else
                    If InStr(1, Oldvalue, Newvalue) = 0 Then
                        Target.Value = Oldvalue & ", " & Newvalue
                    Else
                        Target.Value = Oldvalue
                End If
            End If
        End If
    End If
Exitsub:
    Application.EnableEvents = True
End Sub

 

[ckaval89]

Kod tam istediğim gibi çalıştı. Çok teşekkür ederim desteğiniz için.