Renkli Hücreleri Diğer Sayfaya Aktarmak

[Mukteda]

Kıymetli Arkadaşlar Merhaba,

Kısayol olarak CTRL+B yi atadım. Yani ctrl+b ye basıldığı zaman hata raporları sayfasındaki sarı ile boyalı hücreler hatalılar sayfasına geliyor.

Ama her basışınızda tekrar geliyor.

Benim istediğim eğer önceden o hata rapor numarasında bir hatalı ürün varsa ctrl+b ye bastığımda o tekrar gelmesin istiyorum Kısacası yeni boyadıklarım sürekli SIRASI İLE eklenecek.

TEŞEKKÜRLER...

KOD:

Sub aktar()

sat = WorksheetFunction.CountA(Worksheets("hatalılar").Range("A2:A27")) + 2
For i = 2 To Worksheets("hataraporları").[a65536].End(3).Row
If Sheets("hataraporları").Cells(i, 1).Interior.ColorIndex = 6 Then
For j = 1 To 49
Sheets("hatalılar").Cells(sat, j).Value = Sheets("hataraporları").Cells(i, j).Value
Next
sat = sat + 1
End If
Next i
MsgBox " işlem Tamanlanmıştır..."

End Sub

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub aktar()
    Dim Sat As Long
    Dim i   As Long
    Dim sr  As Worksheet
    Dim sh  As Worksheet
    Dim c   As Range
    Dim Adet As Integer
 
    Set sr = Sheets("hataraporları")
    Set sh = Sheets("hatalılar")
 
    Sat = sh.Cells(Rows.Count, "A").End(3).Row
 
    Application.ScreenUpdating = False
 
    For i = 4 To sr.Cells(Rows.Count, "B").End(3).Row
        If[B][COLOR=red] Not[/COLOR][/B] sr.Cells(i, 1).Interior.ColorIndex = [COLOR=red][B]xlNone[/B][/COLOR] Then
            Set c = sh.Range("a:a").Find(sr.Cells(i, "B"), LookIn:=xlValues, LookAt:=xlWhole)
            If c Is Nothing Then
                    Sat = Sat + 1
                    Adet = Adet + 1
                    sr.Range(Cells(i, "B"), Cells(i, "J")).Copy
                    sh.Cells(Sat, "A").PasteSpecial Paste:=xlPasteValues
                End If
        End If
    Next i
 
    If Adet > 0 Then
        MsgBox Adet & " işlem Tamanlanmıştır..."
    Else
        MsgBox "AKTARILACAK KAYIT BULAMADIM..."
    End If
End Sub

 

[Mukteda]

Teşekkürler

Merhaba,

Aşağıdaki kodları dener misiniz?
[/CODE]

İlginiz için çok teşekkür ederim. Müsaadenizle birkaç sorum olacak:

1- sr.Range(Cells(i, "B"), Cells(i, "J")).Copy
böyle bir hata aldım. Nedeni ne olabilir?

2- Renkli hücrelerin sarı renk olması şart mı? Farklı bir renkli olabilir mi?

3- Bu liste diyelim ki bu hali ile 20 satırdan oluşuyor. Fakat daha sonra bu liste 100 satıra ulaşacak problem olur mu?


Kolay gelsin.

 

[baydeniro]

Sayın Necdet Yeşertener, çok çok güzel bir kod, elinize sağlık.

 

[Mukteda]

Arkadaşlar bu biraz acil. Tekrar bakabilir misiniz?

Excel'e deği ama VBA'ya biraz yabancıyım. Nerede hata yapıyorum acaba?

 

[baydeniro]

Merhaba arkadasca. Üstadın yazdığı kodu şu şekilde dener misin !!


Sub aktar()
Dim Sat As Long
Dim i As Long
Dim sr As Worksheet
Dim sh As Worksheet
Dim c As Range
Dim Adet As Integer
Set sr = Sheets("hataraporları")
Set sh = Sheets("hatalılar")
Sat = sh.Cells(Rows.Count, "A").End(3).Row
Application.ScreenUpdating = False
For i = 4 To sr.Cells(Rows.Count, "A").End(3).Row
If sr.Cells(i, 1).Interior.ColorIndex = 6 Then
Set c = sh.Range("a:a").Find(sr.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
If c Is Nothing Then
Sat = Sat + 1
Adet = Adet + 1
sr.Range(Cells(i, "A"), Cells(i, "I")).Copy
sh.Cells(Sat, "A").PasteSpecial Paste:=xlPasteValues
End If
End If
Next i
If Adet > 0 Then
MsgBox Adet & " işlem Tamanlanmıştır..."
Else
MsgBox "AKTARILACAK KAYIT BULAMADIM..."
End If
End Sub

 

[Mukteda]

Merhaba arkadasca. Üstadın yazdığı kodu şu şekilde dener misin !!

İlginiz için teşekkür ederim.

Kolay gelsin.

 

[Necdet]

1- sr.Range(Cells(i, "B"), Cells(i, "J")).Copy
böyle bir hata aldım. Nedeni ne olabilir?

2- Renkli hücrelerin sarı renk olması şart mı? Farklı bir renkli olabilir mi?

3- Bu liste diyelim ki bu hali ile 20 satırdan oluşuyor. Fakat daha sonra bu liste 100 satıra ulaşacak problem olur mu?

Siz sarı renk dediğiniz için sarı renk kodunu kullandım, yukarıdaki mesajımda bunu kaldırdım yeniden kopyalayınız.

Satır adedi ile kısıtlanmadı.

Copy komutunda verdiği hatanın ne olabileceğini tam olarak anlamadım kodları deneyerek yükledim.

 

[Mukteda]

Sn. Necdet Yeşertener ilginiz için çok teşekkür ederim.