Renk Arama Makrosu

[meyill]

Bir sayfada sarı renkli hücrelerdeki değerleri son sütüna yazmasını sağlamak için bir makro yazmaya çalıştım. Fakat makroyu çalıştırdığımda çok uzun sürüyor. Daha hızlı çalışan bir kod bulmam mümkün mü? Bilen arkadaşların yardımına ihtiyacım var.

Sub ders()
Range("BI8:BI54").ClearContents
For i = 2 To 60
For j = 8 To 53
If Cells(j, i).Interior.ColorIndex = 6 Then
      Cells(j, "bi") = Cells(j, i)
End If
Next j, i
End Sub

 

[Ömer BARAN]

Merhaba.

Aşağıdaki gibi deneyin.
.

[B]Sub SARILAR()[/B]
Application.Calculation = xlCalculationManual
Columns("BI").ClearContents
For Each hucre In Range("A8:BH53")
    If hucre.Interior.ColorIndex = 6 Then _
    Cells(Cells(Rows.Count, "BI").End(3).Row + 1, "BI") = hucre
Next
Application.Calculation = xlCalculationAutomatic
[B]End Sub[/B]

 

[meyill]

Teşekkür ederim Ömer Bey. renkli olan bütün satırları sıralıyor. Sayfada satırlarda birden fazla sarı var. Sadece birini yazmasını istiyorum. Hazırladığınız makro hepsini yazdığı için sıra kayıyor.

 

[Korhan Ayhan]

Örnek dosya ekleyerek açıklama yapabilir misiniz?

 

[meyill]

Buyurun Dosyayı ekledim.

 

[Ömer BARAN]

Kullandığınız Sub ders() başlıklı kod'u;
-- ya alt taraftan ilgili sayfa adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçerek
erişebileceğiniz ilgili sayfanın kod bölümüne alıp, sayfa aktif iken çalıştırın,
-- ya da kod'daki Range(... veya Cells(... satırlarının başında;
Sheets("Sheet1").Range(.... /// Sheets("Sheet1").Cells(... şeklinde sayfa adı belinterek çalıştırın.
.

 

[meyill]

Teşekkür ederim..

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub Ders()
    Dim X As Integer, S1 As Worksheet, Renk_Bul As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set S1 = Sheets("Sheet1")
    S1.Range("BI8:BI54").ClearContents
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    For X = 8 To Son Step 2
        Application.FindFormat.Clear
        Application.FindFormat.Interior.Color = 65535
        Set Renk_Bul = S1.Range("A" & X & ":BH" & X + 1).Find("", SearchFormat:=True)
        If Not Renk_Bul Is Nothing Then
            Cells(Renk_Bul.Row, "BI") = Renk_Bul
            Cells(Renk_Bul.Row + 1, "BI") = Renk_Bul.Offset(1, 0)
        End If
    Next
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub