Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   2 Çalışma Sayfasının Renklı Alanları Tek Sayfa Yapma (http://www.excel.web.tr/showthread.php?t=168012)

aksoy53 09-11-2017 15:30

2 Çalışma Sayfasının Renklı Alanları Tek Sayfa Yapma
 
1 Eklenti(ler)
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 09-11-2017 15:42

Kod:

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 09-11-2017 16:40

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 09-11-2017 21:58

Kod:

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 10-11-2017 20:14

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 11-11-2017 17:06

1 Eklenti(ler)
Örnek dosyanız.

aksoy53 11-11-2017 18:43

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

askm 11-11-2017 19:33

Rica ederim. Hayırlı akşamlar.


Saat 02:49

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.