2 Çalışma Sayfasının Renklı Alanları Tek Sayfa Yapma

[aksoy53]

Sayfa 1 ve sayfa 2'de renkli olan satırları "2 sayfayı birleştirme" yerine tek sayfa olarak aktarmak istiyorum.

Kitap sayımı yaparken 2 bilgisayardan daha hızlı olsun diye işaretleme yaptığımızdan 2 listeyi renkli olanları tek liste halıne getirmek istiyorum yardımlarınız için şimdiden teşekkür ederim.

 

[askm]

Sub askm()
Dim s1, SAYFA As Worksheet
Dim Son As Long
Set s1 = Sheets("2 SAYFAYI BİRLEŞTİRME")
Application.ScreenUpdating = False
s1.Range("A2:D65000").Clear
For Each SAYFA In ThisWorkbook.Worksheets
    If SAYFA.Name <> "2 SAYFAYI BİRLEŞTİRME" Then
    Son = SAYFA.Range("B" & Rows.Count).End(xlUp).Row
        For i = 2 To Son
            If SAYFA.Cells(i, 1).Interior.Color <> xlNone Then
                SAYFA.Range("A" & i & ":D" & i).Copy s1.Cells(65536, "A").End(3).Offset(1, 0)
            End If
        Next i
    End If
Next SAYFA
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[aksoy53]

Hocam eline koluna sağlık yaptım allah razı olsun fakat aktarırken unuttum aktarılan satırları silebilirmi eklenebilirmi (1. ve 2. Sayfadan) kodda işaretlenmeyeni bulmam için

 

[askm]

Sub askm()
Dim s1, SAYFA As Worksheet
Dim Son As Long
Set s1 = Sheets("2 SAYFAYI BİRLEŞTİRME")
Application.ScreenUpdating = False
s1.Range("A2:D65000").Clear
For Each SAYFA In ThisWorkbook.Worksheets
    If SAYFA.Name <> "2 SAYFAYI BİRLEŞTİRME" Then
    Son = SAYFA.Range("B" & Rows.Count).End(xlUp).Row
        For i = 2 To Son
            If SAYFA.Cells(i, 1).Interior.Color <> xlNone Then
                SAYFA.Range("A" & i & ":D" & i).Copy s1.Cells(65536, "A").End(3).Offset(1, 0)
                SAYFA.Rows(i).Delete
                i = i - 1
            End If
        Next i
    End If
Next SAYFA
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[aksoy53]

Sayın Hocam bu kod çalışmadı 1. sayfayı tamamen sildi 2. sayfadakileri aktardı ama silmedi.
Şöyle yapabilirmiyiz hocam sizide yordum hakkınızı helal edin renkli olmayanları 1. ve 2. sayfada "2 sayfayı birleştir" aktarabilirmi sorun daha çabuk çözülebilir.

 

[askm]

Örnek dosyanız.

 

[aksoy53]

Çok teşekkür ederim duyarlılığınıza her şey gönlünce olsun allah razı olsun.

 

[askm]

Rica ederim. Hayırlı akşamlar.