Soru Satır Dolu İse VE Dolu Satırları Kopyalama

Szg15 · 1 Ocak 2021

Merhabalar.

-Sayfa1’deki D2:H aralığından F2:F sütunu DOLU OLANLARI, RAPOR isimli sayfanın B2:F aralığına kopyalayıp yapıştırmasını,

-Sayfa2’nin I3:M3 aralığından itibaren AŞAĞIYA DOĞRU KAÇ SATIR DOLU İSE bunları da RAPOR isimli sayfanın B2:F aralığına, Sayfa1’den kopyalanıp yapıştırılanların hemen altından itibaren kopyalayıp yapıştırmasını istiyorum.

@Ziynettin bey sayfa1’den kopyalanacak veriler için aşağıdaki kodları hazırlamıştı.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("RAPOR")

s2.Range("B2:F" & Rows.Count).ClearContents

son = s1.Cells(Rows.Count, "f").End(3).Row
If son < 2 Then Exit Sub
tbl = s1.Range("D1:H" & son).Value
For i = 2 To UBound(tbl)
If tbl(i, 3) <> "" Then
s = s + 1
For j = 1 To UBound(tbl, 2)
tbl(s, j) = tbl(i, j)
Next j
End If
Next i
If s > 0 Then
s2.[B2].Resize(s, UBound(tbl, 2)) = tbl
MsgBox "İşlem bitti.", vbInformation
Else
MsgBox "Yazdırılacak veri bulunamdı.", vbCritical
End If
End Sub

Ben Sayfa2’den kopyalanmasını istediklerim için uğraştım ancak yapamadım. Yardımcı olursanız çok memnun olurum. Herkese sağlıklı ve huzurlu bir yıl dilerim.

Korhan Ayhan · 1 Ocak 2021

Örnek dosya paylaşınız.

Szg15 · 1 Ocak 2021

Korhan Ayhan' Alıntı:
Örnek dosya paylaşınız.

ANA SAYFA’nın C3:I aralığından, F3:F sütunu dolu olanları, RAPOP isimli sayfanın B2:H aralığına kopyalayıp yapıştırmasını, (bu işlem mevcut kodlarla gerçekleşiyor)

KADRO DIŞI’nın K3:Q aralığından itibaren aşağıya doğru dolu olan tüm satırları, RAPOP isimli sayfanın B2:H aralığına ANA SAYFADAN kopyalayıp yapıştırdıklarının hemen altından itibaren kopyalayıp yapıştırmasını yapmaya çalışıyorum Korhan bey.

Bu arada RAPOR isimli sayfadaki bicimlendir makrosu size ait

Örnek dosya EK'tedir.

Korhan Ayhan · 1 Ocak 2021

Deneyiniz.

Hem Rapor isimli kodu hem de "Bicimlendir" isimli makroyu düzenledim.

C++:

Sub Rapor()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim tbl As Variant, i As Long, s As Long, j As Integer, Son As Long
    
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("RAPOR")
    Set S3 = Sheets("KADRO DIŞI")
    
    S2.Range("B2:H" & Rows.Count).ClearContents
    
    Son = S1.Cells(Rows.Count, "f").End(3).Row
    If Son < 2 Then Exit Sub
    
    tbl = S1.Range("C3:I" & Son).Value

    For i = 2 To UBound(tbl)
        If tbl(i, 3) <> "" Then
            s = s + 1
            For j = 1 To UBound(tbl, 2)
                tbl(s, j) = tbl(i, j)
            Next j
        End If
    Next i
    
    If s > 0 Then
        S2.Select
        S2.[B2].Resize(s, UBound(tbl, 2)) = tbl
        Son = S3.Cells(Rows.Count, "k").End(3).Row
        If Son > 2 Then
            S3.Range("K3:Q" & Son).Copy
            S2.Cells(S2.Rows.Count, 1).End(3)(2, 2).PasteSpecial xlValues
            S2.Range("G2:H" & S2.Cells(S2.Rows.Count, 1).End(3).Row).NumberFormat = "dd.mm.yyy"
            Range("A1").Select
            Application.CutCopyMode = 0
        End If
        MsgBox "GAYRİ BEYANI OLUŞTURULDU", vbInformation
    Else
        MsgBox "Yazdırılacak veri bulunamdı.", vbCritical
    End If
End Sub

Sub Bicimlendir()
    Dim Son As Long
    
    Son = Cells(Rows.Count, 3).End(3).Row
    
    If Son < 2 Then
        MsgBox "Sayfada biçimlendirilecek veri bulunamadı!", vbExclamation
        Exit Sub
    End If
    
    Range("A2:H" & Rows.Count).Borders.LineStyle = 0
    
    With Range("A2:A" & Son)
        With ActiveSheet
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("C2:C" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("D2:D" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("E2:E" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("F2:F" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SetRange Range("A1:G" & Son)
            .Sort.Header = xlYes
            .Sort.MatchCase = False
            .Sort.Orientation = xlTopToBottom
            .Sort.SortMethod = xlPinYin
            .Sort.Apply
        End With
        
        .Formula = "=ROW()-1"
        .Value = .Value
        .Offset(-1).Resize(.Rows.Count + 1, 8).Borders.LineStyle = 1
        .Offset(, 6).Resize(.Rows.Count, 2).NumberFormat = "dd.mm.yyyy"
    
        .Offset(Son + 3, 1).Resize(3, 1).Value = Sheets("VERİ").Range("D1:D3").Value
        .Offset(Son + 3, 3).Resize(3, 1).Value = Sheets("VERİ").Range("E1:E3").Value
        .Offset(Son + 3, 5).Resize(3, 1).Value = Sheets("VERİ").Range("F1:F3").Value
    End With

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Szg15 · 1 Ocak 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

Hem Rapor isimli kodu hem de "Bicimlendir" isimli makroyu düzenledim.

C++:

Sub Rapor()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim tbl As Variant, i As Long, s As Long, j As Integer, Son As Long
   
    Set S1 = Sheets("ANA SAYFA")
    Set S2 = Sheets("RAPOR")
    Set S3 = Sheets("KADRO DIŞI")
   
    S2.Range("B2:H" & Rows.Count).ClearContents
   
    Son = S1.Cells(Rows.Count, "f").End(3).Row
    If Son < 2 Then Exit Sub
   
    tbl = S1.Range("C3:I" & Son).Value

    For i = 2 To UBound(tbl)
        If tbl(i, 3) <> "" Then
            s = s + 1
            For j = 1 To UBound(tbl, 2)
                tbl(s, j) = tbl(i, j)
            Next j
        End If
    Next i
   
    If s > 0 Then
        S2.Select
        S2.[B2].Resize(s, UBound(tbl, 2)) = tbl
        Son = S3.Cells(Rows.Count, "k").End(3).Row
        If Son > 2 Then
            S3.Range("K3:Q" & Son).Copy
            S2.Cells(S2.Rows.Count, 1).End(3)(2, 2).PasteSpecial xlValues
            S2.Range("G2:H" & S2.Cells(S2.Rows.Count, 1).End(3).Row).NumberFormat = "dd.mm.yyy"
            Range("A1").Select
            Application.CutCopyMode = 0
        End If
        MsgBox "GAYRİ BEYANI OLUŞTURULDU", vbInformation
    Else
        MsgBox "Yazdırılacak veri bulunamdı.", vbCritical
    End If
End Sub

Sub Bicimlendir()
    Dim Son As Long
   
    Son = Cells(Rows.Count, 3).End(3).Row
   
    If Son < 2 Then
        MsgBox "Sayfada biçimlendirilecek veri bulunamadı!", vbExclamation
        Exit Sub
    End If
   
    Range("A2:H" & Rows.Count).Borders.LineStyle = 0
   
    With Range("A2:A" & Son)
        With ActiveSheet
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("C2:C" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("D2:D" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("E2:E" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("F2:F" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SetRange Range("A1:G" & Son)
            .Sort.Header = xlYes
            .Sort.MatchCase = False
            .Sort.Orientation = xlTopToBottom
            .Sort.SortMethod = xlPinYin
            .Sort.Apply
        End With
       
        .Formula = "=ROW()-1"
        .Value = .Value
        .Offset(-1).Resize(.Rows.Count + 1, 8).Borders.LineStyle = 1
        .Offset(, 6).Resize(.Rows.Count, 2).NumberFormat = "dd.mm.yyyy"
   
        .Offset(Son + 3, 1).Resize(3, 1).Value = Sheets("VERİ").Range("D1:D3").Value
        .Offset(Son + 3, 3).Resize(3, 1).Value = Sheets("VERİ").Range("E1:E3").Value
        .Offset(Son + 3, 5).Resize(3, 1).Value = Sheets("VERİ").Range("F1:F3").Value
    End With

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan bey vakit ayırıp ilgilendiğiniz için çok teşekkür ederim.

Rapor isimli makroda,
-ANA SAYFA'nın 3'üncü satırında F sütunu dolu olmasına rağmen RAPOR sayfasına kopyalayıp yapıştırmıyor,
-ANA SAYFA'da F sütunu boş olanlardan bazılarını da RAPOR sayfasına kopyalayıp yapıştırıyor, (F sütunu boş ise rapora aktarmasına gerek yok)
-KADRO DIŞI sayfasındakileri kopyalayınca, RAPOR sayfasının 2'nci satırından itibaren yapıştırıyor, daha önce ANA SAYFA'dan buraya yapıştırılan verilerin üzerine yapıştırıyor yani. Örnek dosya ekledim bakabilirseniz çok memnun olurum.

Bicimlendir makrosu sorunsuz çalışıyor emeğinize sağlık.

Korhan Ayhan · 1 Ocak 2021

Kodunuzda ANA SAYFA ile ilgili bölüme hiç müdahale etmedim. Eski hali neyse o şekilde duruyor. Sadece kodun alt kısmına KADRO DIŞI sayfasındaki aktarılacak bölümü kopyala-değer olarak yapıştır işlemini ekledim.

Szg15 · 1 Ocak 2021

Korhan Ayhan' Alıntı:
Kodunuzda ANA SAYFA ile ilgili bölüme hiç müdahale etmedim. Eski hali neyse o şekilde duruyor. Sadece kodun alt kısmına KADRO DIŞI sayfasındaki aktarılacak bölümü kopyala-değer olarak yapıştır işlemini ekledim.

Tamam hocam ben biraz daha çalışayım üzerinde. Çok teşekkür ederim. Sağlıcakla kalın

Soru Satır Dolu İse VE Dolu Satırları Kopyalama

Szg15

Korhan Ayhan

Administrator

Szg15

Ekli dosyalar

Korhan Ayhan

Administrator

Szg15

Ekli dosyalar

Korhan Ayhan

Administrator

Szg15