Makro ile sayfalardan değer çekmek

[yakupoca]

Merhaba arkadaşlar,

Excelde 5 sayfam var her sayfada ilk 5 sütunda TC,adı ,soyadı ,telefon,mail gibi bilgiler var .ben rapor diye bir sayfa oluşturdum ve bu sayfada açılan bir kutuda 5 sayfadaki TC leri altalta gösterttim. Amacım kutudan bir TC seçtiğimde 5 sayfadan hangilerinde o TC varsa bilgilerini Report sayfasına getirtmek.

Yardımlarınız için Teşekkür ederim.

 

[zafer]

Merhaba

Açıklamanız yeterli fakat daha iyi sonuç almak için
örnek dosya ekleyebilirmisiniz.

 

[yakupoca]

ilgilendiğiniz için teşekkür ederim. Örnek dosyayı ekledim.

 

[Vedat Özer]

Selamlar,


Aşagıdaki kodları boş bir modul ekleyip butona bağlayıp denermisiniz,

Option Explicit
Sub sayfalardan_aktar_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
On Error Resume Next
Dim bordo, mavi, kral, asi, kesici
Set bordo = Sheets("Sayfa1")
Set mavi = Sheets("Sayfa2")
Set kral = Sheets("Sayfa3")
Set asi = Sheets("Sayfa4")
Set kaplan = Sheets("Reoport")
kaplan.Select
ts = ActiveCell.Address
trabzonspor = MsgBox(Range("B4") & " Olan Verileri" _
& " Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
Range("A8:D" & Rows.Count).ClearContents
trabzonspor = kaplan.Range("A" & Rows.Count).End(xlUp).Row
kesici = bordo.Range("A" & Rows.Count).End(xlUp).Row
bordo.Range("A1:D" & kesici).AutoFilter field:=3, Criteria1:= _
kaplan.Range("B4")
bordo.Range("A2:D" & kesici).SpecialCells(xlCellTypeVisible).Copy
kaplan.Range("A" & trabzonspor + 1).PasteSpecial (xlPasteValues)
bordo.Range("A1:D" & kesici).AutoFilter
trabzonspor = kaplan.Range("A" & Rows.Count).End(xlUp).Row
kesici = mavi.Range("A" & Rows.Count).End(xlUp).Row
mavi.Range("A1:D" & kesici).AutoFilter field:=3, Criteria1:= _
kaplan.Range("B4")
mavi.Range("A2:D" & kesici).SpecialCells(xlCellTypeVisible).Copy
kaplan.Range("A" & trabzonspor + 1).PasteSpecial (xlPasteValues)
mavi.Range("A1:D" & kesici).AutoFilter
trabzonspor = kaplan.Range("A" & Rows.Count).End(xlUp).Row
kesici = kral.Range("A" & Rows.Count).End(xlUp).Row
kral.Range("A1:D" & kesici).AutoFilter field:=3, Criteria1:= _
kaplan.Range("B4")
kral.Range("A2:D" & kesici).SpecialCells(xlCellTypeVisible).Copy
kaplan.Range("A" & trabzonspor + 1).PasteSpecial (xlPasteValues)
kral.Range("A1:D" & kesici).AutoFilter
trabzonspor = kaplan.Range("A" & Rows.Count).End(xlUp).Row
kesici = asi.Range("A" & Rows.Count).End(xlUp).Row
asi.Range("A1:D" & kesici).AutoFilter field:=3, Criteria1:= _
kaplan.Range("B4")
asi.Range("A2:D" & kesici).SpecialCells(xlCellTypeVisible).Copy
kaplan.Range("A" & trabzonspor + 1).PasteSpecial (xlPasteValues)
asi.Range("A1:D" & kesici).AutoFilter
kaplan.Select
Range(ts).Select
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & " Sürede" & vbLf _
& Range("B4") & " Verilerini Aktardım", , "Bitiş - asi_komando"
End Sub

 

[yakupoca]

Yardımlarınız için çok Teşekkür ederim Vedat Bey Tam istediğim gibi sonuç verdi.

Keyifli Çalışmalar dilerim.