• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Boş olanları diğer sayfaya aktar

Merhaba
Aşağıdaki kodları denermisiniz?
Kod:
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
 
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
Kod:
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.
 
Son düzenleme:
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.

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


Kod:
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
 
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.

Kod:
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
 
Son düzenleme:
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
 
Aşağıdaki gibi deneyiniz.

Kod:
    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
 
Korhan bey çok teşekkür ederim dua ile kalın hayırlı sahurlar dualarımız sizinle ...
 
Geri
Üst