• DİKKAT

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

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

Merhaba,
Şu kodları deneyiniz...
Kod: 
Sub kod()
For Each hcr In Range("N6:AR155")
    If hcr.Interior.Color = vbYellow Then hcr.Value = "X"
Next
End Sub
 
alirizapekbilir' Alıntı:
N6:AR155 arasında SARI olan hücreleri makro ile X atmak mümkünmü ?
Genişletmek için tıkla ...
Buyurun.:cool:
Kod: 
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
 
Teşekkürler hocam :) sizlerin şu bildiğinin %10 unu bilmek isterdim. İyi bir ekipsiniz.
 
Alternatif;

Renge göre filtre yapıp görünür hücrelere "X" yazabilirsiniz.
 
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.
 
Amacınız koşullu biçimlendirme ile renklenen hücreleri sorgulamak ise aşağıdaki kodu kullanabilirsiniz.

Kod: 
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
 
Puantaj sayfasında hücre rengi sarı olanlara B yapmak istedim. sayfa parolaları 61
Belki örnek dosya istersiniz diye ekledim.
 

Ekli dosyalar

Önerdiğim kodu kullanabilirsiniz.
 
Aşağıdaki gibi deneyiniz.

Kod: 
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
 
Kusura bakmayın hocam run time 438 hatası hala devam ediyor. Sorunu çözemeyecek kadar zayıfım.
 
Üstteki mesajımda ki koda küçük bir ekleme daha yaptım. Tekrar deneyiniz.

Ben foruma eklediğiniz dosyada sonuç alabiliyorum.
 
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.
 
Hangi excel versiyonunu kullanıyorsunuz?

Profilinizde 2013 yazıyor.
 
Kullanılan makro kodu 2010 ve üzeri versiyonlarda çalışmaktadır.
 
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
 
Merhaba,

Foruma kod eklerken lüften "code" tagını kullanınız. Mesaj yazdığınız pencerede ... (üç nokta) şeklindeki seçenekten erişebilirsiniz.
 
Uyardığınız için teşekkürler dikkat edeceğim hocam.

Kod: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst