Sarı hücrelere "X" işareti atma.

[alirizapekbilir]

N6:AR155 arasında SARI olan hücreleri makro ile X atmak mümkünmü ?

 

[ÖmerBey]

Merhaba,
Şu kodları deneyiniz...

Sub kod()
For Each hcr In Range("N6:AR155")
    If hcr.Interior.Color = vbYellow Then hcr.Value = "X"
Next
End Sub

 

[Orion1]

N6:AR155 arasında SARI olan hücreleri makro ile X atmak mümkünmü ?

Buyurun.

Sub sarihucreler()
Dim hcr As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each hcr In Range("N6:AR155")
    If hcr.Interior.Color = vbYellow Then hcr.Value = "X"
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "BİTTİ"
End Sub

 

[alirizapekbilir]

Teşekkürler hocam sizlerin şu bildiğinin %10 unu bilmek isterdim. İyi bir ekipsiniz.

 

[Korhan Ayhan]

Alternatif;

Renge göre filtre yapıp görünür hücrelere "X" yazabilirsiniz.

 

[alirizapekbilir]

Makro yeni sayfada çalışıyor ama çalışmama eklediğimde çalışmıyor. Sayfada bir çok koşullu biçimlendirmeler var. Uzunda bir makronun içine ekleyecektim.

 

[Korhan Ayhan]

Amacınız koşullu biçimlendirme ile renklenen hücreleri sorgulamak ise aşağıdaki kodu kullanabilirsiniz.

Sub X_Yaz()
    Dim Veri As Range
    Range("N6:AR155").ClearContents
    For Each Veri In Range("N6:AR155")
        If Veri.DisplayFormat.Interior.ColorIndex = 6 Then
            Veri.Value = "X"
        End If
    Next
End Sub

 

[alirizapekbilir]

Puantaj sayfasında hücre rengi sarı olanlara B yapmak istedim. sayfa parolaları 61
Belki örnek dosya istersiniz diye ekledim.

 

[Korhan Ayhan]

Önerdiğim kodu kullanabilirsiniz.

 

[alirizapekbilir]

kullandım hata vedi hocam. run time error 438 hatası

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz.

Sub X_Yaz()
    Dim Veri As Range
    Sheets("Puantaj").Select
    ActiveSheet.Unprotect "61"
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    For Each Veri In Range("N6:AR155")
        If Veri.DisplayFormat.Interior.ColorIndex = 6 Then
            If Cells(Veri.Row, "L") <> "" Then Veri.Value = "X"
        End If
    Next
    ActiveSheet.Protect "61"
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[alirizapekbilir]

Kusura bakmayın hocam run time 438 hatası hala devam ediyor. Sorunu çözemeyecek kadar zayıfım.

 

[Korhan Ayhan]

Üstteki mesajımda ki koda küçük bir ekleme daha yaptım. Tekrar deneyiniz.

Ben foruma eklediğiniz dosyada sonuç alabiliyorum.

 

[alirizapekbilir]

Hocam aynı hatayı verdi. Doğru olabilir belki kullandığım excel versiyonu ile alakalı olabilir. Evdeki bilgisayarımdan denedim yarın işyerindeki bilgisayardan tekrar deneyip konuya yazayım. Emeğiniz için teşekkürler.

 

[Korhan Ayhan]

Hangi excel versiyonunu kullanıyorsunuz?

Profilinizde 2013 yazıyor.

 

[alirizapekbilir]

Hocam evdeki 2007 miş. Genelde işyerinden bağlanıyorum. Farketmedim

 

[Korhan Ayhan]

Kullanılan makro kodu 2010 ve üzeri versiyonlarda çalışmaktadır.

 

[alirizapekbilir]

Hocam makro çalıştı versiyon farkından kaynaklanmış. Bir ilavem olabilirmi acaba. Sizin makroyu benim puantele() makrosunun sonuna ilave ettim çalışıyor. Eğer tarihlerden biri boşsa çalışmıyor makroyu hangi kodun arasına almam lazımki her şartta çalışsın.

Sizin kod en sonda kod
Çok uzun olduğu için aradan tekrarlayanları sildim.

Sub puantele()
ActiveSheet.Unprotect "61"
sor = MsgBox("Puantaj Bilgilerini temizlemek ve YENİ PUANTAJ oluşturmak istiyormusunuz? Eğer EVET derseniz kaydı geri alamazsınız.!!!", 20, "UYARI")
If sor = vbNo Then Exit Sub
sor = MsgBox("Eminmisiniz! Aksi halde tüm puantaj bilgilerini tekrar girmek zorunda kalabilirsiniz. Bu işlem kişi başoı ortalama 1,5 sn. sürecek...", 20, "SON UYARI")
If sor = vbNo Then Exit Sub
ActiveSheet.Unprotect "61"
Range("N6:AR155").Select
Selection.ClearContents
ActiveSheet.Protect "61"
Range("N6").Select

'1. Tarih
tarihkontrol = Range("N5").Value
tarih = Range("N5").Value

Dim SonSat As Long
SonSat = Range("L" & Rows.Count).End(xlUp).Row

If tarihkontrol = "" Then
Exit Sub
Else
If Weekday(tarih, vbMonday) = 1 Or Weekday(tarih, vbMonday) = 2 Or Weekday(tarih, vbMonday) = 3 Or Weekday(tarih, vbMonday) = 4 Or Weekday(tarih, vbMonday) = 5 Then
For i = 6 To SonSat
Range("N" & i).Value = "X"
Next i
Else
If Weekday(tarih, vbMonday) = 6 Then
For i = 6 To SonSat
Range("N" & i).Value = "AT"
Next i
Else
For i = 6 To SonSat
Range("N" & i).Value = "P"
Next i
End If
End If
End If

'2. Tarih
tarihkontrol = Range("O5").Value
tarih = Range("O5").Value
If tarihkontrol = "" Then
Exit Sub
Else
If Weekday(tarih, vbMonday) = 1 Or Weekday(tarih, vbMonday) = 2 Or Weekday(tarih, vbMonday) = 3 Or Weekday(tarih, vbMonday) = 4 Or Weekday(tarih, vbMonday) = 5 Then
For i = 6 To SonSat
Range("O" & i).Value = "X"
Next i
Else
If Weekday(tarih, vbMonday) = 6 Then
For i = 6 To SonSat
Range("O" & i).Value = "AT"
Next i
Else
For i = 6 To SonSat
Range("O" & i).Value = "P"
Next i
End If
End If
End If
.
.
.
.
.
.
.
.
'30. Tarih
tarihkontrol = Range("AQ5").Value
tarih = Range("AQ5").Value
If tarihkontrol = "" Then
Exit Sub
Else
If Weekday(tarih, vbMonday) = 1 Or Weekday(tarih, vbMonday) = 2 Or Weekday(tarih, vbMonday) = 3 Or Weekday(tarih, vbMonday) = 4 Or Weekday(tarih, vbMonday) = 5 Then
For i = 6 To SonSat
Range("AQ" & i).Value = "X"
Next i
Else
If Weekday(tarih, vbMonday) = 6 Then
For i = 6 To SonSat
Range("AQ" & i).Value = "AT"
Next i
Else
For i = 6 To SonSat
Range("AQ" & i).Value = "P"
Next i
End If
End If
End If


'31. Tarih
tarihkontrol = Range("AR5").Value
tarih = Range("AR5").Value
If tarihkontrol = "" Then
Exit Sub
Else
If Weekday(tarih, vbMonday) = 1 Or Weekday(tarih, vbMonday) = 2 Or Weekday(tarih, vbMonday) = 3 Or Weekday(tarih, vbMonday) = 4 Or Weekday(tarih, vbMonday) = 5 Then
For i = 6 To SonSat
Range("AR" & i).Value = "X"
Next i
Else
If Weekday(tarih, vbMonday) = 6 Then
For i = 6 To SonSat
Range("AR" & i).Value = "AT"
Next i
Else
For i = 6 To SonSat
Range("AR" & i).Value = "P"
Next i
End If
End If
End If

Dim Veri As Range
Sheets("Puantaj").Select
ActiveSheet.Unprotect "61"
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
For Each Veri In Range("N6:AR155")
If Veri.DisplayFormat.Interior.ColorIndex = 6 Then
If Cells(Veri.Row, "L") <> "" Then Veri.Value = "B"
End If
Next
ActiveSheet.Protect "61"
MsgBox "İşleminiz tamamlanmıştır. X-AT-P-B dışındaki kodlarınızı işleyebilirsiniz..", vbInformation

End Sub

 

[Korhan Ayhan]

Merhaba,

Foruma kod eklerken lüften "code" tagını kullanınız. Mesaj yazdığınız pencerede ... (üç nokta) şeklindeki seçenekten erişebilirsiniz.

 

[alirizapekbilir]

Uyardığınız için teşekkürler dikkat edeceğim hocam.

Sub puantele()

ActiveSheet.Unprotect "61"

sor = MsgBox("Puantaj Bilgilerini temizlemek ve YENİ PUANTAJ oluşturmak istiyormusunuz? Eğer EVET derseniz kaydı geri alamazsınız.!!!", 20, "UYARI")
If sor = vbNo Then Exit Sub

sor = MsgBox("Eminmisiniz! Aksi halde tüm puantaj bilgilerini tekrar girmek zorunda kalabilirsiniz. Bu işlem kişi başoı ortalama 1,5 sn. sürecek...", 20, "SON UYARI")
If sor = vbNo Then Exit Sub

ActiveSheet.Unprotect "61"
    Range("N6:AR155").Select
    Selection.ClearContents
ActiveSheet.Protect "61"
    Range("N6").Select

'1. Tarih
tarihkontrol = Range("N5").Value
tarih = Range("N5").Value

Dim SonSat As Long
SonSat = Range("L" & Rows.Count).End(xlUp).Row

If tarihkontrol = "" Then
Exit Sub
Else
If Weekday(tarih, vbMonday) = 1 Or Weekday(tarih, vbMonday) = 2 Or Weekday(tarih, vbMonday) = 3 Or Weekday(tarih, vbMonday) = 4 Or Weekday(tarih, vbMonday) = 5 Then
For i = 6 To SonSat
Range("N" & i).Value = "X"
Next i
Else
If Weekday(tarih, vbMonday) = 6 Then
For i = 6 To SonSat
Range("N" & i).Value = "AT"
Next i
Else
For i = 6 To SonSat
Range("N" & i).Value = "P"
Next i
End If
End If
End If

'2. Tarih
tarihkontrol = Range("O5").Value
tarih = Range("O5").Value
If tarihkontrol = "" Then
Exit Sub
Else
If Weekday(tarih, vbMonday) = 1 Or Weekday(tarih, vbMonday) = 2 Or Weekday(tarih, vbMonday) = 3 Or Weekday(tarih, vbMonday) = 4 Or Weekday(tarih, vbMonday) = 5 Then
For i = 6 To SonSat
Range("O" & i).Value = "X"
Next i
Else
If Weekday(tarih, vbMonday) = 6 Then
For i = 6 To SonSat
Range("O" & i).Value = "AT"
Next i
Else
For i = 6 To SonSat
Range("O" & i).Value = "P"
Next i
End If
End If
End If
.
.
.
.
.
'30. Tarih
tarihkontrol = Range("AQ5").Value
tarih = Range("AQ5").Value
If tarihkontrol = "" Then
Exit Sub
Else
If Weekday(tarih, vbMonday) = 1 Or Weekday(tarih, vbMonday) = 2 Or Weekday(tarih, vbMonday) = 3 Or Weekday(tarih, vbMonday) = 4 Or Weekday(tarih, vbMonday) = 5 Then
For i = 6 To SonSat
Range("AQ" & i).Value = "X"
Next i
Else
If Weekday(tarih, vbMonday) = 6 Then
For i = 6 To SonSat
Range("AQ" & i).Value = "AT"
Next i
Else
For i = 6 To SonSat
Range("AQ" & i).Value = "P"
Next i
End If
End If
End If


'31. Tarih
tarihkontrol = Range("AR5").Value
tarih = Range("AR5").Value
If tarihkontrol = "" Then
Exit Sub
Else
If Weekday(tarih, vbMonday) = 1 Or Weekday(tarih, vbMonday) = 2 Or Weekday(tarih, vbMonday) = 3 Or Weekday(tarih, vbMonday) = 4 Or Weekday(tarih, vbMonday) = 5 Then
For i = 6 To SonSat
Range("AR" & i).Value = "X"
Next i
Else
If Weekday(tarih, vbMonday) = 6 Then
For i = 6 To SonSat
Range("AR" & i).Value = "AT"
Next i
Else
For i = 6 To SonSat
Range("AR" & i).Value = "P"
Next i
End If
End If
End If
    
    Dim Veri As Range
    Sheets("Puantaj").Select
    ActiveSheet.Unprotect "61"
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    For Each Veri In Range("N6:AR155")
        If Veri.DisplayFormat.Interior.ColorIndex = 6 Then
            If Cells(Veri.Row, "L") <> "" Then Veri.Value = "B"
        End If
    Next
    ActiveSheet.Protect "61"
    MsgBox "İşleminiz tamamlanmıştır. X-AT-P-B dışındaki kodlarınızı işleyebilirsiniz..", vbInformation

End Sub