Soru Veri Girişi Engelleme

[Hsn55]

İyi günler;
Ekli dosyada Ebat Girişi -1-2-3-4-5 sayfalarında sarı renkli sütunlarda veri yoksa sağındaki hücre girişlerine izin verilmeyecek. Sarı renkli sütunlarda veri varsa sağındaki sütundaki hücrelere sol sütunda yazan veriden fazlasına girişe izin verilmeyecek. Uyarı verecek

Örnek: sol taraf boş ise sağ tarafa izin yok
Örnek: G24 hücresinde 8 rakamı var ben H24 hücresine 8'in üstünde bir sayı yazdığım zaman izin vermeyecek. Bildirim yaparak giriş engellenecek.

İndir 2024 DEPO PROGRAMI SON xlsm

Dosyayı indir 2024 DEPO PROGRAMI SON xlsm

dosya.co

 

[Hsn55]

İyi akşamlar, konuya makro ile çözüm getirebilir misiniz?

 

[Trilenium]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim gCell As Range
Dim hCell As Range
Dim i As Integer
Dim colPairs As Variant

' Kontrol edilecek kolon çiftleri
colPairs = Array("G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD")

Application.EnableEvents = False
For i = LBound(colPairs) To UBound(colPairs) Step 2
Dim col1 As String
Dim col2 As String
col1 = colPairs(i)
col2 = colPairs(i + 1)

' Kontrol edilecek hücre aralığı
Dim gRange As Range
Dim hRange As Range

Set gRange = Range(col1 & "20:" & col1 & "69")
Set hRange = Range(col2 & "20:" & col2 & "69")

' Değiştirilen hücreler içinde kontrol yap
If Not Intersect(Target, gRange) Is Nothing Or Not Intersect(Target, hRange) Is Nothing Then
For Each cell In Target
If Not Intersect(cell, hRange) Is Nothing Then
Set hCell = cell
Set gCell = gRange.Cells(hCell.Row - gRange.Row + 1, 1)

Debug.Print "Kontrol edilen hücre: " & hCell.Address

' H hücresine girilen değer G hücresindeki değerden büyükse veya G hücresi boşsa uyarı ver
If (gCell.Value = "" And hCell.Value <> "") Or (gCell.Value <> "" And hCell.Value > gCell.Value) Then
MsgBox "Girdiğiniz değer daha önce girilen değerden büyük veya hücre boş olduğu için " & col2 & hCell.Row & " hücresine giriş yapılamaz."
hCell.ClearContents
End If
End If
Next cell
End If
Next i
Application.EnableEvents = True
End Sub

 

[Hsn55]

Hocam hiç bir girişe izin vermiyor

 

[Hsn55]

Arkadaşlar iyi günler, konuya destek olursanız sevinirim şimdiden teşekkürler

 

[pitchoute]

Merhaba, deneyip sonucu paylaşabilir misiniz;

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim gCell As Range
    Dim hCell As Range
    Dim i As Integer
    Dim colPairs As Variant
    
    colPairs = Array("G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD")
    Application.EnableEvents = False
    For Each cell In Target
        For i = LBound(colPairs) To UBound(colPairs) Step 2
            Dim col1 As String
            Dim col2 As String
            col1 = colPairs(i)
            col2 = colPairs(i + 1) 
            If cell.Column = Columns(col2).Column Then
                Set hCell = cell
                Set gCell = Cells(hCell.Row, Columns(col1).Column)
                If IsEmpty(gCell.Value) And Not IsEmpty(hCell.Value) Then
                    MsgBox "Sol taraftaki hücre boşken " & col2 & hCell.Row & " hücresine giriş yapılamaz.", vbExclamation, "Uyarı"
                    hCell.ClearContents
                    Exit For
                ElseIf Not IsEmpty(gCell.Value) And IsNumeric(hCell.Value) And IsNumeric(gCell.Value) Then
                    If Val(hCell.Value) > Val(gCell.Value) Then
                        MsgBox col2 & hCell.Row & " hücresine, " & gCell.Value & " değerinden büyük bir değer giremezsiniz.", vbExclamation, "Uyarı"
                        hCell.ClearContents
                        Exit For
                    End If
                End If
            End If
        Next i
    Next cell
    Application.EnableEvents = True
End Sub

 

[Hsn55]

Merhaba, deneyip sonucu paylaşabilir misiniz;

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim gCell As Range
    Dim hCell As Range
    Dim i As Integer
    Dim colPairs As Variant
   
    colPairs = Array("G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD")
    Application.EnableEvents = False
    For Each cell In Target
        For i = LBound(colPairs) To UBound(colPairs) Step 2
            Dim col1 As String
            Dim col2 As String
            col1 = colPairs(i)
            col2 = colPairs(i + 1)
            If cell.Column = Columns(col2).Column Then
                Set hCell = cell
                Set gCell = Cells(hCell.Row, Columns(col1).Column)
                If IsEmpty(gCell.Value) And Not IsEmpty(hCell.Value) Then
                    MsgBox "Sol taraftaki hücre boşken " & col2 & hCell.Row & " hücresine giriş yapılamaz.", vbExclamation, "Uyarı"
                    hCell.ClearContents
                    Exit For
                ElseIf Not IsEmpty(gCell.Value) And IsNumeric(hCell.Value) And IsNumeric(gCell.Value) Then
                    If Val(hCell.Value) > Val(gCell.Value) Then
                        MsgBox col2 & hCell.Row & " hücresine, " & gCell.Value & " değerinden büyük bir değer giremezsiniz.", vbExclamation, "Uyarı"
                        hCell.ClearContents
                        Exit For
                    End If
                End If
            End If
        Next i
    Next cell
    Application.EnableEvents = True
End Sub

Sayın pitchoute yine olmuyor. Girişe izin vermiyor

 

[Trilenium]

Olmuyordu çünkü veri girişini var var olan hücrenin solunda ki veriden kontrol ediyorduk. Sol kısımda yer alan veri ise formülle hareket ediyordu. Formülle hareket ettiği içinde kontrolü sağlayamıyorduk.


Aşağıda yer alan kodla,gezinilen hücrenin değerini değişkene atadık, ve kontrolü değişkenle karşılaştırıyoruz.

Yani önce satırda yazan değeri elimizde tutuyoruz, eldeki değer ile girilen değeri karşılaştırıyoruz.

Dim gValue As Variant ' gValue'yu Variant olarak tanımlayalım

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim colPairs As Variant
Dim gCell As Range
Dim hCell As Range
Dim i As Integer

' Kontrol edilecek kolon çiftleri
colPairs = Array("G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD")

For i = LBound(colPairs) To UBound(colPairs) Step 2
Dim col1 As String
Dim col2 As String
col1 = colPairs(i)
col2 = colPairs(i + 1)

' H hedef hücresi içinde olup olmadığını kontrol et
If Not Intersect(Target, Range(col2 & "20:" & col2 & "69")) Is Nothing Then
For Each hCell In Target
Set gCell = Range(col1 & hCell.Row)
If Not IsEmpty(gCell) Then
gValue = gCell.Value ' Değeri gValue değişkenine ata
Debug.Print "G hücresindeki değer (gValue değişkenine atandı): " & gValue
End If
Next hCell
End If
Next i
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim gCell As Range
Dim hCell As Range
Dim i As Integer
Dim colPairs As Variant

' Kontrol edilecek kolon çiftleri
colPairs = Array("G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD")

Application.EnableEvents = False
For i = LBound(colPairs) To UBound(colPairs) Step 2
Dim col1 As String
Dim col2 As String
col1 = colPairs(i)
col2 = colPairs(i + 1)

' Kontrol edilecek hücre aralığı
Set gRange = Range(col1 & "20:" & col1 & "69")
Set hRange = Range(col2 & "20:" & col2 & "69")

' Değiştirilen hücreler içinde kontrol yap
If Not Intersect(Target, hRange) Is Nothing Then
For Each cell In Target
' Sadece hRange içinde değeri değiştirilmiş hücreleri kontrol et
If Not Intersect(cell, hRange) Is Nothing Then
Set hCell = cell
Set gCell = gRange.Cells(hCell.Row - gRange.Row + 1, 1)

Debug.Print "Kontrol edilen hücre: " & hCell.Address

' G hücresindeki değeri kontrol et
If IsEmpty(gValue) Then
MsgBox "G hücresi boş olduğu için " & col2 & hCell.Row & " hücresine giriş yapılamaz."
hCell.ClearContents
ElseIf hCell.Value > gValue Then
MsgBox "Girdiğiniz değer, G hücresindeki değerden büyük olduğu için " & col2 & hCell.Row & " hücresine giriş yapılamaz."
hCell.ClearContents
End If
End If
Next cell
End If
Next i
Application.EnableEvents = True
End Sub

 

[Hsn55]

Hocam değişen bir şey olmadı. Yine aynı . Hiçbir şekilde giriş olmuyor