Yalnız Mesajı Göster
Eski 09-11-2017, 21:58  
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,594
Excel Vers. ve Dili:
2010-2016
Varsayılan

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla