Belirli satırlar hariç kopyalama

[Bagcivan]

Merhabalar,
Birinci sayfadaki beyaza boyanmış, boş bırakılmış ve değeri 0 olanlar hariç, diğer satırları 2.Sayfaya kopyalamak istiyorum.
Yardımcı olabilir misiniz

ornek.xlsx dosyasını indir - download

ornek.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s4.dosya.tc

 

[NADİR YILDIZ]

Sayfa 1 b sütununda boş olanlar haricindekileri filtreleyip sayfa2 ye aktarabilirsiniz.
sayfa 2 yi temizleyebilirsiniz

iyi çalışmalar

 

[Bagcivan]

Sayfa 1 b sütununda boş olanlar haricindekileri filtreleyip sayfa2 ye aktarabilirsiniz.
sayfa 2 yi temizleyebilirsiniz

iyi çalışmalar

Sayın Nadir merhaba
Bu tek seferlik değil ve ayıklama ak veri sayısı fazla. Bu yüzden makroyla sürekli olarak aktarmak gerekiyor.

 

[Korhan Ayhan]

Tablonuzda "J" sütunu boş görünüyor bu sütun işleme dahil edilecek mi?

 

[Korhan Ayhan]

Deneyin bakalım olmuş mu?

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long
    Dim Son As Long, Say As Long, Y As Byte, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    S2.Range("A2:J" & S2.Rows.Count).Clear
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    ReDim Liste(1 To Son, 1 To 9)
    
    For X = 2 To Son
        If S1.Cells(X, 1).Font.ColorIndex <> 2 Then
            If WorksheetFunction.CountA(S1.Range("A" & X & ":I" & X)) <> 9 Then
                If WorksheetFunction.CountIf(S1.Range("A" & X & ":I" & X), 0) <> 9 Then
                    Say = Say + 1
                    For Y = 1 To 9
                        Liste(Say, Y) = S1.Cells(X, Y)
                    Next
                End If
            End If
        End If
    Next
    
    If Say > 0 Then
        S2.Range("A2").Resize(Say, 9) = Liste
        S2.Range("A2").Resize(Say, 9).Font.ColorIndex = False
        S2.Range("A1:J" & Say + 1).Borders.LineStyle = 1
        S2.Range("A1:C1").BorderAround 1, xlMedium
        S2.Range("A1:J1").BorderAround 1, xlMedium
        S2.Range("A2").Resize(Say, 10).BorderAround 1, xlMedium
        S2.Range("A2").Resize(Say, 1).BorderAround 1, xlMedium
        S2.Range("B2").Resize(Say, 2).BorderAround 1, xlMedium
        S2.Select
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[Bagcivan]

Deneyin bakalım olmuş mu?

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long
    Dim Son As Long, Say As Long, Y As Byte, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
   
    S2.Range("A2:J" & S2.Rows.Count).Clear
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
   
    ReDim Liste(1 To Son, 1 To 9)
   
    For X = 2 To Son
        If S1.Cells(X, 1).Font.ColorIndex <> 2 Then
            If WorksheetFunction.CountA(S1.Range("A" & X & ":I" & X)) <> 9 Then
                If WorksheetFunction.CountIf(S1.Range("A" & X & ":I" & X), 0) <> 9 Then
                    Say = Say + 1
                    For Y = 1 To 9
                        Liste(Say, Y) = S1.Cells(X, Y)
                    Next
                End If
            End If
        End If
    Next
   
    If Say > 0 Then
        S2.Range("A2").Resize(Say, 9) = Liste
        S2.Range("A2").Resize(Say, 9).Font.ColorIndex = False
        S2.Range("A1:J" & Say + 1).Borders.LineStyle = 1
        S2.Range("A1:C1").BorderAround 1, xlMedium
        S2.Range("A1:J1").BorderAround 1, xlMedium
        S2.Range("A2").Resize(Say, 10).BorderAround 1, xlMedium
        S2.Range("A2").Resize(Say, 1).BorderAround 1, xlMedium
        S2.Range("B2").Resize(Say, 2).BorderAround 1, xlMedium
        S2.Select
    End If
   
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Sayın Korhan,
Olmuş gibi görünüyor. Şimdi farklı dosyalarda deneyeceğim.
Teşekkür ederim.