• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Satırda zorunlu hücre alanları

burhancavus61

burhancavus61

Katılım
13 Mayıs 2005
Mesajlar
761
Excel Vers. ve Dili
2010 Türkçe
Sayfadaki satırda C D E F G H hücreleri dolmadan diğer hücreye geçiş izni vermemek mümkünmü ve makro ile. bu hücrelerden birine veri yazınca mutlaka diğerlerinide doldurmak zorunda olmalı. Sadece C D E F G ve H sütunları için geçerli olmalı 150. satıra kadar.
 
Bu konuya benzer olarak daha önce 3 Koşullu uyarı isimli konuda 2 numaralı mesajda paylaştığım kod işinize yarayabilir.
 
Buna benzer ama ben mesela a hücresini doldurdum b hücresini doldurmadan c ye izin vermesin c dolmadan d ye izin vermesin bunun gibi istiyorum taki h hücreside dolduktan sonra diğe hücrelere izin versin.
 
Merhaba
Aşağıdaki gibi işinize yararmı?
İlgili sayfanın kod penceresine yazıp deneyiniz
("C" ve "H" sütunları aralıkları dışındaki seçimler hariç)
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("C1:C150,D1:D150,E1:E150,F1:F150,G1:G150,H1:H150")) Is Nothing Then Exit Sub
For Each j In Range("C1:H150")
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.Row & ":H" & Target.Row)) < 6 Then
If j = "" Then j.Select: Exit Sub
End If: Next
End Sub

"C" ve "H" sütunları aralıkları dışındaki seçimlerde dahil olsun derseniz;
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("C1:C150,D1:D150,E1:E150,F1:F150,G1:G150,H1:H150")) Is Nothing Then
For Each j In Range("C1:H150")
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.Row & ":H" & Target.Row)) < 6 Then
If j = "" Then j.Select: Exit Sub
End If: Next
Else
Cells(Cells(Rows.Count, "C").End(3).Row + 1, "C").Select
End If
End Sub
 
Son düzenleme:
C son satıra tıklayın ca en üste atıyor dson satırına geçmeme izin vermiyor
 
C3 satırını doldurup D3 satırına geçeceğim D3 doldurmadan E3 e geçmeme izin vermemesi lazım. her satırda aynı mantık
 
Kodlardaki aşağıdaki "1" leri kaçıncı sütundan itibaren veri yazıyorsanız değişmelisiniz

If Not Intersect(Target, Range("C1:C150,D1: D50,E1:E150,F1:F150,G1:G150,H1:H150")) Is Nothing Then
For Each j In Range("C1:H150")


Ekteki örnekte "C3:H150" aralığı ayarlı
https://dosyaup.com/d/EFWQCGZLJ

Acaba yanlışmı anladım;
"Yan hücreye geçemeyecek ama alt satıra geçebilecek" gibimi?
 
anladım galiba ama ilk giriş yaptığım yere düzeltme için dönebilmem lazım.
 
makro güzel çalışıyor fakat sizin kodlarda geri dönüyor ama bende dönmüyor. kendime göre uyarlamıştım

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("C3:C150,D3:D150,E3:E150,F3:F150,G3:G150,J3:J150")) Is Nothing Then Exit Sub
For Each j In Range("C3:J150")
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.row & ":J" & Target.row)) < 9 Then
If j = "" Then j.Select: Exit Sub
End If: Next
End Sub
 
Range("C3:C150,D3: D150,E3:E150,F3:F150,G3:G150,J3:J150"))


"H" sütunun yerine "J" sütununumu aldınız,
"H" ve "I" sütunu olmayacaksa ona göre düzenleyelim

"H" ,"I" ve "J" sütunları dahil ise ve düzenlemek için geri dönmek gerekirse şöyle
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("C3:C150,D3:D150,E3:E150,F3:F150,G3:G150,H3:H150,I3:I150,J3:J150")) Is Nothing Then Exit Sub
If Selection.Cells.Count <> 1 Then ActiveCell.Activate
For Each j In Range("C3:J150")
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.Row & ":H" & Target.Row)) < 6 Then
If ActiveCell <> "" And j <> ActiveCell Then Exit Sub
If j = "" Then j.Select: Exit Sub
End If: Next
End Sub
 
Son düzenleme:
Ama o sütunları doldurdum bu şekilde de işimi gördü. H ve I sütununu atlamak isteseydim nasıl yapmalıydım peki.
 
burhancavus61' Alıntı:
Ama o sütunları doldurdum bu şekilde de işimi gördü. H ve I sütununu atlamak isteseydim nasıl yapmalıydım peki.
Genişletmek için tıkla ...
Ekteki gibi
https://dosyaup.com/d/FGAYIJVM
Şöyle;
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("C3:C150,D3:D150,E3:E150,F3:F150,G3:G150,J3:J150")) Is Nothing Then Exit Sub
If Selection.Cells.Count <> 1 Then ActiveCell.Activate
For Each j In Range("C3:G150,J3:J150")
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.Row & ":H" & Target.Row)) < 6 Then
If ActiveCell <> "" And j <> ActiveCell Then Exit Sub
If j = "" Then j.Select: Exit Sub
End If: Next
End Sub
 
Çok güzel oldu teşekkür ederim. İmlecin olduğu alanı sarı renklendirebilirmiyiz. Yazdıktan sonra tekrar dolgu rengi olmasın bu makroya ilave edebilirmiyiz.
 
Aşağıdaki gibi deneyin, hem yukarıdaki son eklediğim kodda eksiklik gördüm
https://dosyaup.com/d/IIQT
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Range("C3:G150,J3:J150").Interior.ColorIndex = xlNone
If Intersect(Target, Range("C3:C150,D3:D150,E3:E150,F3:F150,G3:G150,J3:J150")) Is Nothing Then Exit Sub
If Selection.Cells.Count <> 1 Then ActiveCell.Activate
For Each j In Range("C3:J150")
If j.Column <> 8 And j.Column <> 9 Then
Target.Interior.Color = 65535
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.Row & ":G" & Target.Row, "J" & Target.Row)) < 6 Then
If ActiveCell <> "" And j <> ActiveCell Then Exit Sub
If j = "" Then j.Select: Exit Sub
End If: End If: Next
End Sub
 
Rica ederim güle güle kullanın ayrıca aşağıdaki gibide Sayfa hücreleri komple seçilirse hata vermesin;
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo 10
Range("C3:G150,J3:J150").Interior.ColorIndex = xlNone
If Intersect(Target, Range("C3:C150,D3:D150,E3:E150,F3:F150,G3:G150,J3:J150")) Is Nothing Then Exit Sub
If Selection.Cells.Count <> 1 Then: ActiveCell.Select
For Each j In Range("C3:J150")
If j.Column <> 8 And j.Column <> 9 Then
If Selection.Cells.Count = 1 Then ActiveCell.Interior.Color = 65535
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.Row & ":G" & Target.Row, "J" & Target.Row)) < 6 Then
If ActiveCell <> "" And j <> ActiveCell Then Exit Sub
If j = "" Then j.Select: Exit Sub
End If: End If: Next
10:
End Sub
 
Hocam merhaba; kod çalışıyor. Sayfa koruması yaptığımda çalışmıyor. Bu sorunu nasıl çözeriz.
 
Kodlar aşağıdaki gibi çalışacaktır ama nasıl yazıyorsunuz?
(123 leri şifrenizle değiştirirsiniz)
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Unprotect "123" '<-----------------------'
On Error GoTo 10
Range("C3:G150,J3:J150").Interior.ColorIndex = xlNone
If Intersect(Target, Range("C3:C150,D3:D150,E3:E150,F3:F150,G3:G150,J3:J150")) Is Nothing Then GoTo 10
If Selection.Cells.Count <> 1 Then: ActiveCell.Select
For Each j In Range("C3:J150")
If j.Column <> 8 And j.Column <> 9 Then
If Selection.Cells.Count = 1 Then ActiveCell.Interior.Color = 65535
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.Row & ":G" & Target.Row, "J" & Target.Row)) < 6 Then
If ActiveCell <> "" And j <> ActiveCell Then GoTo 10
If j = "" Then j.Select: GoTo 10
End If: End If: Next
10:
ActiveSheet.Protect "123"  '<--------------------------------'
End Sub

Yazablmek için aşağıdaki gibi yapalım
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Unprotect "123"
On Error GoTo 10
With Range("C3:G150,J3:J150")
.Interior.ColorIndex = xlNone
.Locked = True
.FormulaHidden = True
End With
If Intersect(Target, Range("C3:C150,D3:D150,E3:E150,F3:F150,G3:G150,J3:J150")) Is Nothing Then GoTo 10
If Selection.Cells.Count <> 1 Then: ActiveCell.Select
For Each j In Range("C3:J150")
If j.Column <> 8 And j.Column <> 9 Then
If Selection.Cells.Count = 1 Then ActiveCell.Interior.Color = 65535
If j.Value = "" And WorksheetFunction.CountA(Range("C" & Target.Row & ":G" & Target.Row, "J" & Target.Row)) < 6 Then
If ActiveCell <> "" And j <> ActiveCell Then GoTo 10
If j = "" Then
j.Select
j.Locked = False
j.FormulaHidden = False
: GoTo 10
End If
End If: End If: Next
10:
ActiveSheet.Protect "123"
End Sub
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst