Farklı tabloya işaretleri satırları aktarma

[FurkanAcar]

Merhabalar,

80.000 satırlı bir tabloda sadece işaretli olan 6.000-7.000 veriyi farklı bir tabloya aktarmak istiyorum. Kopyala-yapıştır ile yapmak hem uğraşlı hem de formüllerden gelen değerleri çekmiyor.


örnek dosya :

http://dosya.co/vyssm804kpoy/2014_Canlı_Data.rar.html


Not: Sarı renkli satırları aynen farklı bir tabloya aktarmak istiyorum.

 

[Ömer BARAN]

Merhaba.

30 MB boyutunda (sanırım gerçek belgeniz) örnek belge biraz garip değil mi sizce de?
Böyle olunca, işlemi öğrenmek veya yapmak yerine yaptırmak istediğiniz gibi bir sonuç çıkıyor.

Örnek belgenin, varsa farklı alternatifler için bir veya birkaç satırlık veri içermesi yeterlidir.

Örnek belgeden beklenen;
-- gerçek belgeyle aynı yapıda olması,
-- özel bilgileri (telefon/ad soyad/adres gibi) içermemesi,
-- gerçek verileri temsil edebilecek ve tutarlı az miktarda veri içermesi,
-- varsa formül/kod/userform'ların belge içerisinde ve çalışır durumda olması,
-- örnek verilere göre olması gereken sonuçların da elle yazılarak hazırlanmasıdır.

Yukarıda belirttiğim şekilde hazırlanmış bir örnek belge üzerinden destek istemenizi öneriyorum.
.

 

[tahsinanarat]

Aşağıdaki kodları deneyiniz (bu siteden temin edilen kodlardır)

Private Sub CommandButton1_Click()
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim MyRng As Range
    Dim Nrow As Long
    Set Sh1 = Sheets("Grid Results")
    Set Sh2 = Sheets("Sayfa2")
    Sh2.Range("A2:BZ65536").ClearContents
    Sh2.Range("A2:BZ65536").Interior.ColorIndex = xlNone
    
        For Each MyRng In Sh1.Range("A1:BZ" & Sh1.Range("A65536").End(3).Row)
            If MyRng.Interior.ColorIndex = 6 Then
            If WorksheetFunction.CountIf(Sh2.Range("A2:A65536"), Sh1.Cells(MyRng.Row, "A")) = 0 Then
            Nrow = Sh2.Range("A65536").End(xlUp).Row + 1
            Sh1.Rows(MyRng.Row).Copy Sh2.Range("A" & Nrow)
            End If
            End If
        Next

    Range("A1").Select
    Sh2.Select

    With Rows("2:65536").Font
        .Size = 7
        .Name = "Arial"
    End With
    
    Range("A1").Select
    
    'Me.Hide
    ActiveWindow.SelectedSheets.PrintPreview
    Sheets("Sayfa2").Select
    'Me.Show
End Sub

 

[tahsinanarat]

Dosyanız ekli linkde

Dosyanız aşağıdaki linktde
http://s9.dosya.tc/server3/e77x11/Renkli_satirlari_aktar.rar.html