hücre içinde başında *yıldız varsa şarta bağlı işlem

[netvolxxx]

Merhaba sitedeki örneklere baktım hepsinin mantığı başında yada içerik geçen kelime ile satır hücrelere ait koruma kaldırma ile örnekler var c5 alanı normal kelimesi geçerse w3 ile w100 arası gibi bide hücre koruması kalkması için şifre sorarak işlem yaptırılmış hep her seferinde şifre girmek zor iş...

benim yapmak istediğim tam olarak şu örnek verecek olursam

c5 c10 c15 hep +5 şeklinde devam ediyor

c5 *deneme
c10 *test
c15 denelemer
başında yıldız * varsa sadece karşılığı olan hücre koruması kalksın yani c5 *deneme e5
c10 *test e10

c15 yıldız işareti yoksa e15 hücre korumalı kalcak

isim yazan hücreler c alanı karşılığı ise e alanı

bu işlemi kod ile nasıl yapabilirim acaba.....

 

[Trilenium]

doğru anladıysam


Sub kilitle()
Dim ws As Worksheet
Dim cell As Range
Dim rowNumber As Long


Set ws = ThisWorkbook.Sheets("Sheet5")

ws.Unprotect Password:="yourpassword"


ws.Columns("A:xfd").Locked = False


For rowNumber = 5 To ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Step 5
Set cell = ws.Cells(rowNumber, "C")
' Hücrede yıldız (*) olup olmadığını kontrol ediliyor
If Left(cell.Value, 1) <> "*" Then

ws.Cells(cell.Row, "E").Locked = True
End If
Next rowNumber


ws.Protect Password:="yourpassword"

MsgBox "İşlem tamamlandı!", vbInformation
End Sub

 

[netvolxxx]

doğru anladıysam


Sub kilitle()
Dim ws As Worksheet
Dim cell As Range
Dim rowNumber As Long


Set ws = ThisWorkbook.Sheets("Sheet5")

ws.Unprotect Password:="yourpassword"


ws.Columns("A:xfd").Locked = False


For rowNumber = 5 To ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Step 5
Set cell = ws.Cells(rowNumber, "C")
' Hücrede yıldız (*) olup olmadığını kontrol ediliyor
If Left(cell.Value, 1) <> "*" Then

ws.Cells(cell.Row, "E").Locked = True
End If
Next rowNumber


ws.Protect Password:="yourpassword"

MsgBox "İşlem tamamlandı!", vbInformation
End Sub

merhaba evet üstad istediğim buydu tam olarak sağolasın teşekürr ederim....

 

[netvolxxx]

üstad kodda şöyle bir sorun var bi kere çalışıyor kod ikinci işlemi yapmak istediğimde çalışmıyor sayfayı korumak için girdiğim şifrede geçersiz kabul etmiyor 123456 şifresi diyelim ayrıca c5 hücresinde *deneme yazıyor karşılığı e5 değiştirmeye izin vercek ama c6 hücresinde *test yazsada karşılığı e6 izin vermicek... hep +5 şeklinde yapı...

 

[Trilenium]

dosya örneğiniz yok.. sorunuz böyle mi ?

 

[netvolxxx]

Ekli dosyayı görüntüle 254508

dosya örneğiniz yok.. sorunuz böyle mi ?

*test yazan karşılığı kilitlenmesin olacak c5
c6 kilitle
c7 kilitle
c8 kilitle
c9 kilitle
kilitli kalcak...

diğerleri ok doğru
c11
c12
c13
c14

 

[netvolxxx]

ustad bu şekil dosya eklemedim evet haklısın valla 1 saat uğraşıyom yapamadım bi türlü

*test yazan karşılığı kilitlenmesin olacak c5 e5 kilitlenmesin
c6 e6 kilitle
c7 e7 kilitle

 

[netvolxxx]

üstad dosyayı ekledim......

 

[Trilenium]

Sub Kilitle()
Dim ws As Worksheet
Dim cell As Range
Dim rowNumber As Long
Dim targetCell As Range


Set ws = ThisWorkbook.Sheets("Sayfa1") ' Kendi sayfanızın adını buraya yazınız

' önce Sayfa korumasını kaldırıyoruz
ws.Unprotect Password:="12345"

' E sütunundaki tüm hücreleri korumalı hale getiriyoruz
ws.Columns("E:E").Locked = True

' C sütunundaki hücreleri kontrol ederek E sütunundaki ilgili hücrelerin kilidini yönetiyoruz
For rowNumber = 5 To ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Step 5
Set cell = ws.Cells(rowNumber, "C")
' Hücrede yıldız (*) olup olmadığını kontrol ediyoruz
If Left(cell.Value, 1) = "*" Then
' E sütunundaki karşılık gelen birleşik hücreyi kilitlenebilir hale getiriyoruz
Set targetCell = ws.Cells(cell.Row, "E").MergeArea
targetCell.Locked = False
End If
Next rowNumber

' Sayfa korumasını tekrar yapıyoruz
ws.Protect Password:="12345"

MsgBox "İşlem tamamlandı!", vbInformation
End Sub

 

[netvolxxx]

Sub Kilitle()
Dim ws As Worksheet
Dim cell As Range
Dim rowNumber As Long
Dim targetCell As Range


Set ws = ThisWorkbook.Sheets("Sayfa1") ' Kendi sayfanızın adını buraya yazınız

' önce Sayfa korumasını kaldırıyoruz
ws.Unprotect Password:="12345"

' E sütunundaki tüm hücreleri korumalı hale getiriyoruz
ws.Columns("E:E").Locked = True

' C sütunundaki hücreleri kontrol ederek E sütunundaki ilgili hücrelerin kilidini yönetiyoruz
For rowNumber = 5 To ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Step 5
Set cell = ws.Cells(rowNumber, "C")
' Hücrede yıldız (*) olup olmadığını kontrol ediyoruz
If Left(cell.Value, 1) = "*" Then
' E sütunundaki karşılık gelen birleşik hücreyi kilitlenebilir hale getiriyoruz
Set targetCell = ws.Cells(cell.Row, "E").MergeArea
targetCell.Locked = False
End If
Next rowNumber

' Sayfa korumasını tekrar yapıyoruz
ws.Protect Password:="12345"

MsgBox "İşlem tamamlandı!", vbInformation
End Sub

üstad denemedim hiç bir sorun yok teşekürr ederim çok sağolasın.....

 

[Trilenium]

Tamamdır.

Rica ederim kolay gelsin