Kapalı Dosyalardan Veri Almak Hakkında...

[yesimgurol]

Merhabalar,
Klasör içerisinde birden fazla ve aynı formatta excel raporlarım var. Bu raporlar içersindeki "SONUC" sayfalarından "B1:B17" bilgilerini , Aynı klasör içerisine yeni bir excel sayfası açıp oradaki "SONUC" sayfasına yan yana aktarmak istiyorum..
Forumda araştırdım ve bu kodları buldum.Fakat bu kodlarda da sadece tek bir dosyadan veri alıyor yani "kapalı" isimli dosyadan, bu kodları "kapalı" isimli dosyadan değilde klasör içerisindeki tüm excel sayfalarında arama yapması için düzenleme gerekcek sanırım:-(

Sub KOD()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\kapalı.xls"
Workbooks.Open (yol)
Workbooks("Kapalı").Sheets("SONUC").Range("b1:b17").Copy _
Workbooks("Açık").Sheets("SONUC").Range("b1")



Workbooks("Kapalı").Close True

Application.ScreenUpdating = True
MsgBox " B i t t i "

End Sub

 

[Murat OSMA]

Merhaba Yeşim Hanım,

Bu kodları kullanabilirsiniz..

[SIZE="2"]Sub Emre()
    Dim fso As Object, ac As Workbook, yol$, sut%
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    yol = [COLOR="red"]ThisWorkbook.Path[/COLOR]: sut = 2
    For Each dosyalar In fso.getfolder(yol).Files
        If InStr(1, dosyalar.Name, "[COLOR="Red"]Açık[/COLOR]") = 0 Then
            Set [COLOR="Red"]ac[/COLOR] = Workbooks.Open(dosyalar)
            [COLOR="red"]ac.Worksheets[/COLOR]("SONUC").Range("B1:B17").Copy _
            [COLOR="Blue"]ThisWorkbook.Worksheets[/COLOR]("SONUC").Cells(1, sut)
            sut = sut + 1
            ac.Close False
        End If
    Next dosyalar
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı.", vbInformation, "Www.ExcelArsivi.Com"
End Sub[/SIZE]

 

[yesimgurol]

Murat Bey, harikasınız çok teşekkür ederim.:dua2::mutlu::mutlu:

 

[Murat OSMA]

Rica ederim, iyi günler.

Not: Önceki mesajdan alıntı yapmanıza gerek yok, mesajınızdaki alıntıyı silebilirseniz memnun olurum.

Hoşça kalın.​

 

[yesimgurol]

Murat bey,
Çok özür dilerim:-( Bir ricam olacaktı, "B1:B17" alanındaki veriler formüllü olduğundan aktarırken sıfırlı değerleri alıyor:-(

 

[Murat OSMA]

Murat bey,
Çok özür dilerim:-( Bir ricam olacaktı, "B1:B17" alanındaki veriler formüllü olduğundan aktarırken sıfırlı değerleri alıyor:-(

Estağfurullah Yeşim Hanım, sadece önceki mesajı olduğu gibi alıntı yapmayı gereksiz olarak görüyorum. Ayrıca bana göre görüntü kirliliğine yol açıyor, o sebeple rica ettim.


Konu ile ilgili olarak; kodlardaki şu iki satırı değiştirmeniz yeterli olacaktır.
(Eski kodlar yerine bu verdiğim kodları yapıştırınız.)

[SIZE="2"]            ac.Worksheets("SONUC").Range("B1:B17").Copy
            ThisWorkbook.Worksheets("SONUC").Cells(1, sut).PasteSpecial xlPasteValues[/SIZE]

 

[yesimgurol]

Haklısınız, çok teşekür ederim ilginize..

 

[Murat OSMA]

Rica ediyorum, iyi günler.​