Boş olanları diğer sayfaya aktar

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar herkese iyi geceler;
Sizlerden bir isteğim var bunu ekli dosyamda anlattım bununla ilgili bana bir makro yazarsanız sevinirim. Teşekkürler.
http://s9.dosya.tc/server2/znrpb4/GECICI_GOREV_YOLLUGU_LISTESI_2017.xls.html

 

[PLİNT]

Merhaba
Aşağıdaki kodları denermisiniz?

Sub boslar()
Set s1 = Sheets("İCMAL")
Set s2 = Sheets("SON İCMAL")
s1.Columns("J:J").Replace " ", ""
s2.Activate
s2.Range("A3:G" & Rows.Count) = Empty
sat = s1.Cells(Rows.Count, 1).End(3).Row
For Each a In s1.Range("J3:J" & sat).SpecialCells(xlCellTypeBlanks)
s = s + 1
s2.Cells(s + 2, 1) = s
s2.Range("B" & s + 2 & ":G" & s + 2).Value = _
s1.Range("B" & a.Row & ":G" & a.Row).Value
Next
End Sub

 

[Hacı Bayram ÖZKAN]

Sayın PLİNT geç gördüm teşekkürler. Eline sağlık dua ile kal.

 

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar; Sayın PLİNT in hazırlamış olduğu kodla İCMAL sayfasındaki kodları SON İCMAL sayfasına alıyoruz, ancak benim isteğim, İCMAL sayfasında L3 Sütunundan başlayan IBANLAR, son icmal sayfasının H Sütununa almam için kod nasıl olması yani B:G arasına birde L sütunu eklenecek buda tekrar SON İCMAL sayfasının B:H arasına yazacak eski kod aşağıda

Sub boslar()
Set s1 = Sheets("İCMAL")
Set s2 = Sheets("SON İCMAL")
s1.Columns("J:J").Replace " ", ""
s2.Activate
s2.Range("A3:G" & Rows.Count) = Empty
sat = s1.Cells(Rows.Count, 1).End(3).Row
For Each a In s1.Range("J3:J" & sat).SpecialCells(xlCellTypeBlanks)
s = s + 1
s2.Cells(s + 2, 1) = s
[COLOR="Blue"]s2.Range("B" & s + 2 & ":G" & s + 2).Value[/COLOR] = _
[COLOR="Red"]s1.Range("B" & a.Row & ":G" & a.Row).Value[/COLOR]
Next
End Sub

Teşekkürler iyi ramazanlar.

 

[Hacı Bayram ÖZKAN]

Sayin abiler benim soruma bir bakar misiniz? Teşekkürler

 

[Korhan Ayhan]

Deneyiniz.

"J" sütununda ÖDENMEDİ yazanlarda var. Siz boş hücreler aktarılsın demişsiniz. Ben kodu ÖDENDİ yazısına eşit olmayanlar şeklinde düzenledim. Eğer "J" sütunu boş olanların aktarılması gerekiyorsa kod içindeki kırmızı satırı değiştirmeniz gerekecektir.

Kırmızı satırı aşağıraki gibi düzeltirseniz boş olan satırlar aktarılır.

If S1.Cells(X, "J") = Empty Then

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Son As Long, Satir As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("İCMAL")
    Set S2 = Sheets("SON İCMAL")
    S2.Range("A3:H" & S2.Rows.Count).Clear
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Satir = 3
    
    For X = 3 To Son
        [COLOR="Red"]If S1.Cells(X, "J") <> "ÖDENDİ" Then[/COLOR]
            S1.Range("A" & X & ":G" & X).Copy
            S2.Range("A" & Satir).PasteSpecial xlPasteValues
            S2.Range("A" & Satir).PasteSpecial xlPasteFormats
            S2.Cells(Satir, 1) = Satir - 2
            S1.Cells(X, 12).Copy S2.Cells(Satir, 8)
            Satir = Satir + 1
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Hacı Bayram ÖZKAN]

Sayın Korhan bey teşekkür ederim. Dua ile kalın,,,,

 

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar; 6 Nolu mesajda Korhan beyin yazmış olduğu, kodda veriler aktarılırken özellikle İCMAL sayfasında bulunan IBAN düşeyara formülü ile bulunduğu için, bu veriler son icmal sayfasına formül şeklinde aktarılıyor, bunu değer yapıştır şeklinde yapmak için kodda nasıl bir değişiklik yapılır. Mavi ile boyalı kodda bu hatayı yapıyor. Herkese teşekkürler.

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Son As Long, Satir As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("İCMAL")
    Set S2 = Sheets("SON İCMAL")
    S2.Range("A3:H" & S2.Rows.Count).Clear
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Satir = 3
    
    For X = 3 To Son
        If S1.Cells(X, "J") <> "ÖDENDİ" Then
            S1.Range("A" & X & ":G" & X).Copy
            S2.Range("A" & Satir).PasteSpecial xlPasteValues
            S2.Range("A" & Satir).PasteSpecial xlPasteFormats
            S2.Cells(Satir, 1) = Satir - 2
[COLOR="Blue"]            S1.Cells(X, 12).Copy S2.Cells(Satir, 8)[/COLOR]
            Satir = Satir + 1
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Hacı Bayram ÖZKAN]

Selamün aleyküm Korhan bey 8 nolu mesajınızda yazmış olduğunuz kodda mavi ile boyamış olduğum kod verileri aktarırken formül olarak aktarıyor diğerleri gibi aktarmak için kodu değiştirir misin? Teşekkürler

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz.

    For X = 3 To Son
        If S1.Cells(X, "J") <> "ÖDENDİ" Then
            S1.Range("A" & X & ":G" & X).Copy
            S2.Range("A" & Satir).PasteSpecial xlPasteValues
            S2.Range("A" & Satir).PasteSpecial xlPasteFormats
            S2.Cells(Satir, 1) = Satir - 2
            S1.Cells(X, 12).Copy
            S2.Cells(Satir, 8).PasteSpecial xlPasteValues
            S2.Cells(Satir, 8).PasteSpecial xlPasteFormats
            Satir = Satir + 1
        End If
    Next

 

[Hacı Bayram ÖZKAN]

Korhan bey çok teşekkür ederim dua ile kalın hayırlı sahurlar dualarımız sizinle ...