hücreler yazılı değilken renksiz olsun

[mancubus]

kodun en altına End Sub'dan önce gelmek üzere:

Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 0

 

[sensizsoldum]

merhaba mancubus verdiğiniz kodu ekledim hata veriyor. sayfanın en altında End Subdan bir önce yerleştirdim malesef hata verdi

 

[mancubus]

E3:E76 (E'deki son satır örnek dosyada 76; değişebilir, kod bunu dikkate alıyor) aralığında boş hücre bulamamış muhtemelen.

o satırı silerek yerine aşağıdaki kırmızı renkli olanları ekle.
veya kodun tamamı eski kodun yerine...

mevcut durumda test amaçlı aradaki bir-iki hücreyi sil, sonra diğer sayfaya geç, peşinden bu sayfaya. çalışacak.

Private Sub Worksheet_Activate()

Set S1 = Sheets("GELENLER")
Set S2 = Sheets("ANA SAYFA")
S2.Range("A3:d65000").ClearContents

'------------------------ANA SAYFAYA TOPLAMA---------------------------
X = WorksheetFunction.CountA(S1.Range("A3:A65000")) + 3
S = 2
For I = 3 To X
     TIP = S1.Cells(I, 1).Value
     LKS = S1.Cells(I, 3).Value
     If WorksheetFunction.CountIf(S1.Range("A3:A" + Trim(I)), TIP) = 1 Then
        T = WorksheetFunction.CountIf(S1.Range("A:A"), TIP)
        S = S + 1:
        S2.Cells(S, 1).Value = TIP
        S2.Cells(S, 2).Value = LKS
        S2.Cells(S, 3).Value = T
        
        O = 0: Y1 = 0: Y2 = 0
        For K = 1 To 10
          Y1 = Y2
          Y2 = Y2 + 50
          If T > Y1 And T <= Y2 Then O = Round(T / Y2, 2): GoTo TAMAM
        Next K
TAMAM:
        S2.Cells(S, 4).Value = O
        'S2.Cells(S, 7).Value = Trim(Y1) + "-" + Trim(Y2)
     End If
Next I

'------------------------RENKLENDİRME---------------------------------
S1 = WorksheetFunction.CountA(Range("B3:B65000")) + 2
S2 = WorksheetFunction.CountA(Range("E3:E65000")) + 2
Range("E3:E" + Trim(S2)).Interior.ColorIndex = 4
For K = 3 To S2
R = Cells(K, 5).Value
   For I = 3 To S1
      X = 0
      LKS = Cells(I, 2).Value
      X = InStr(LKS, R)
      If X <> 0 Then Range("E" + Trim(K)).Interior.ColorIndex = 3
   Next
Next

[COLOR="Red"]Dim rngBos
On Error Resume Next
Set rngBos = Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
rngBos.Interior.ColorIndex = 0
On Error GoTo 0[/COLOR]

End Sub

 

[sensizsoldum]

iyi akşamlar mancubus,
arkadaşım bu kodu da denedim ama yine sonuca ulaşamadım. e sutuna girişleri manuel olarak giriyorum siliyorum. satır olarak sildiğimizde herhangi bir sorun yok öncekinde de ama hücrelere del yaptığımızda sayfayı güncellediğimizde herhangi bir sonuca gidemedim yine

 

[mancubus]

söz konusu kod çalışma sayfası aktif hale geldiğinde tetiklenen bir kod. yani bu kodun çalışması için başka bir sayfada iken bu sayfanın sekmesine tıklayarak aktif hale getirmek lazım.

bende çalıştığına göre sende de çalışması lazım.

 

[sensizsoldum]

sayın mancubus,
bunu çalışmaya ekleyıp, bide çalışma üzerinden, deneyebilirmıyız.


tşk ederim hayırlı akşamlar

 

[mancubus]

basit bir kod kopyalama için tüm dosyayı eklemek niye.

nasıl yapılacağını tarif edeyim.
imleç ile mesajdaki kodları seç. Ctrl+C
excel'e geç.
Alt ve F11 tuşları birlikte VBE penceresini açar.
açılan pencerede solda sayfa isminin üzerine çift tıklanır.
sağdaki boş alana tıkla. (gerçi eski kodlar burada. boş olmayacak.)
Ctrl+V

 

[sensizsoldum]

malesef dediklerinizi harfiyen yaptım. defalarce kez yaptım. sonuca gidemedim

 

[mancubus]

makrolar etkin değil mi?

 

[sensizsoldum]

merhabalar, günaydın,

sayın mancubus, ilgi alakanız için tşk ederim.
doğrudur çalışıyor, önceki verdiğiniz araya eklenecek kodlarda çalışıyor,
ama sonlardan yapınca düzenli çalışmıyor, hatta eski düzene göre bile çalışmıyor.
bende hep son satırları denediğim için, farkı görmedik. ortalardan yapınca sorun yok, dolayısıyla hep bu yüzden sonuca gidemedik.

 

[mancubus]

74'ten sonra veri olmadığı için çalışmaması normal.

ilave veri girilir ise sayfa değiştirip tekrar bu sayfaya girmek lazım.

son mesajımdır.

 

[sensizsoldum]

tşk ederim tekrardan, çok sağolun saygıyla efendim.
iyi çalışmalar dilerim.