Rapor Sayfasına diğer sayfalardan veri alma

[waytooraider]

Merhaba

Excel dosyasında 10 larca sayfa var.Ve bu sayfalar her geçen gün artıyor.Sayfalar hepsi birbirininin aynısı.
Tüm sayfalarda 4.satırda A'dan R'ye kadar filtre mevcut.L stununda SEC değerlerinin olduğu satırları Aynı dosyadaki rapor kısmına aktarmasını istiyorum.Benzer bir konu varsa yönlendirebilir misiniz,bulamadım?

 

[PLİNT]

Merhaba
Ek dosyayı bir inceleyin olmazsa örneğinizi buraya ekleyip link verirmisiniz? http://s9.dosya.tc/
http://s3.dosya.tc/server10/97s0yd/ARAMA.zip.html

[SIZE="2"]Private Sub CommandButton1_Click()

Dim s1 As Worksheet
Set s1 = Sheets("RAPOR")
For Each a In Worksheets
If a.Name <> "RAPOR" Then
With a.Range("L3:L" & a.Cells(Rows.Count, "L").End(3).Row)
 Set C = .Find("SEC", , xlValues, , , , False)
    If Not C Is Nothing Then
        f = C.Address
        Do
x = s1.Cells(Rows.Count, 1).End(3).Row + 1
a.Cells(C.Row, 1).EntireRow.Copy
s1.Cells(x, 1).PasteSpecial
            Set C = .FindNext(C)
If C Is Nothing Then Exit Do
        Loop While Not C Is Nothing And C.Address <> f
    End If
End With
End If
Next
End Sub[/SIZE]

 

[waytooraider]

Çok teşekkürler sadece A'dan R ye kadar satırı rapora aktarması ve rapor alırken rapor sayfasında önceki verileri temizlemesi mümkün mü(4.satıra kadar) ? Olmasada bu şekilde bile harika oldu.

 

[PLİNT]

Çok teşekkürler sadece A'dan R ye kadar satırı rapora aktarması ve rapor alırken rapor sayfasında önceki verileri temizlemesi mümkün mü(4.satıra kadar) ? Olmasada bu şekilde bile harika oldu.

Kodları aşağıdaki gibi değiştirip deneyin.
"A3" hücresi dolu ise (başlık vb) kırmızı bölümü silersiniz

[SIZE="2"]Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Set s1 = Sheets("RAPOR")
s1.Range("A4:R" & Rows.Count).ClearContents
For Each a In Worksheets
If a.Name <> "RAPOR" Then
With a.Range("L3:L" & a.Cells(Rows.Count, "L").End(3).Row)
 Set c = .Find("SEC", , xlValues, , , , False)
    If Not c Is Nothing Then
        f = c.Address
        Do
x = s1.Cells(Rows.Count, 1).End(3).Row + 1
[COLOR="Red"]If x < 4 Then x = 4[/COLOR]
s1.Range("A" & x & ":R" & x).Value = a.Range("A" & c.Row & ":R" & c.Row).Value
            Set c = .FindNext(c)
If c Is Nothing Then Exit Do
        Loop While Not c Is Nothing And c.Address <> f
    End If
End With
End If
Next
End Sub [/SIZE]