Birden Fazla Sekmeden Veriyi Çekmek!!!

[by_ufuk]

Merhaba Arkadaşlar,
Resimde tam olarak ne yapmak istediğimi belirttim, örnek dosyada ekte bulunmaktadır. Yardımlarınızı bekliyorum.

 

[by_ufuk]

Yardıma gerek kalmadı,bi şekilde makroyu hallettim,yinede teşekkürler

 

[apocalyt]

ben bir makro yazdım..dilerseniz kullanırsınız..

Sub daylight()
Application.ScreenUpdating = False
Sheets(Sheets.Count).Range("a2:b1000").ClearContents
For x = 1 To Sheets.Count - 1
Set ben = Sheets(x).Range("b2:b6").Find("*", , , 1)
adr = Not ben Is Nothing
If adr = True Then
adr1 = ben.Address
Sheets(x).Range("b" & Mid(adr1, 3, 2)).Copy
Sheets(Sheets.Count).Cells(Sheets(Sheets.Count).[b1000].End(3).Row + 1, 2).PasteSpecial
Sheets(x).Range("b1").Copy
Sheets(Sheets.Count).Cells(Sheets(Sheets.Count).[a1000].End(3).Row + 1, 1).PasteSpecial
End If
Do
Set ben = Sheets(x).Range("b2:b6").FindNext(ben)
If ben.Address <> adr1 Then
Sheets(x).Range("b" & ben.Row).Copy
Sheets(Sheets.Count).Cells(Sheets(Sheets.Count).[b1000].End(3).Row + 1, 2).PasteSpecial
Sheets(x).Range("b1").Copy
Sheets(Sheets.Count).Cells(Sheets(Sheets.Count).[a1000].End(3).Row + 1, 1).PasteSpecial
End If
Loop While Not ben Is Nothing And ben.Address <> adr1
Next x
Sheets(Sheets.Count).Range("a2:b10").Sort key1:=Sheets(Sheets.Count).Range("a1")
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[by_ufuk]

apocalyt ilgilendiğin için teşekkür ederim, daha kısa bir makro ile halettim yine de eline sağlık, senin de verdiğin makroyu arşivime ekledim :hey: