Aynı şablonda daki 1 den fazla dosyadan veri almak.

[selim_1]

Arkadaşlar
Aşağıdaki kodda küçük bir değişiklik yaparak,aynı şablondaki 1 den fazla dosyadan B2:AB32 arasındaki dolu satırları Rapor_1 dosyasına aktarabilirmiyiz ?
Yardımlarınız için şimdiden teşekkürler.
Sub Verial()
Dim VeriDosya
Dim i As Byte
ChDrive ("C")
ChDir ("C:/Koop")
Dosya = Dir("*.xls")
While Dosya <> ""
i = i + 1
Workbooks.Open Filename:="C:\Koop\" & Dosya
Workbooks("Koop_Rapor1.xls").ActiveSheet.Cells(i, 2).Value = _
Workbooks(Dosya).ActiveSheet.Range("O33").Value
Workbooks("Koop_Rapor1.xls").ActiveSheet.Cells(i, 3).Value = _
Workbooks(Dosya).ActiveSheet.Range("E33").Value
Workbooks("Koop_Rapor1.xls").ActiveSheet.Cells(i, 4).Value = _
Workbooks(Dosya).ActiveSheet.Range("C33").Value
Workbooks("Koop_Rapor1.xls").ActiveSheet.Cells(i, 1).Value = Dosya
Workbooks(Dosya).Close
Dosya = Dir
Wend
End Sub

 

[Levent Menteşoğlu]

Merhaba

Foruma hoşgeldiniz. Yukarıda verdiğiniz kod, istemiş olduğunuz uygulama için yetersiz kalıyor,yani küçük bir ilave ile amacınızı gerçekleştirmeniz zor. Sorunuzu daha net açıklamak için bir örnek dosya eklemenizde fayda olduğunu düşünüyorum. Buna göre mevcut kod geliştirilebilir yada farklı bir mantıkla yeni bir kod yazılabilir.

selamlar

 

[selim_1]

Veri alınacak örnek dosya ektedir.

 

[Levent Menteşoğlu]

Dosyanızı inceledim fakat tam olarak ne istediğinizi anlamış değilim. Ekteki dosyanız ile ilişkilendirerek detaylı bir açıklama yaparsanız sanırım sorunuz anlaşılacaktır.

 

[selim_1]

Ã?rnek dosyadan kaç adet varsa ,içindeki bilgileri(B2:AB32)
(Toplamlar hariç) Rapor adlı bir dosyada alt alta yazdırıp her satırın toplamını almak istiyorum.

 

[Levent Menteşoğlu]

Aşağıdaki gibi bir kodla birden fazla kitaptan veri çekebilirsiniz. Burada dikkat edilmesi gereken konu tüm kitapların açık olması gerekliliği,bu kodu kendi kodunuza ilave edebilirsiniz. Ã?rneğin burada A1 hücresindeki değer çekiliyor.

[vb:1:696197d36f]For b = 1 To Workbooks.Count - 1
Cells(b, 1) = Workbooks(b).Sheets(1).[a1]
Next b
[/vb:1:696197d36f]

 

[Haluk]

Merhaba;

İstediğinizi tam olarak karşılayacak mı bilemiyorum ama, bir ara aşağıdaki kodları denersiniz.

Deneme yapmak için bu kodları yeni bir çalışma kitabında bir module yerleştirip, dosyayı da veri alınacak diğer dosyaların olduğu klasöre yerleştirin. Daha sonra da prosedurü çalıştırın. Her dosyada "Giriş" adındaki sayfadan B2:AB32 aralığındaki veriler alınacaktır.

[vb:1:315e2dd628]Sub GetData2()
Dim DataFile As String, MyFile As String, MyMsg As String
Dim i As Long, j As Long, MyRow As Long
Dim jj As Integer, k As Integer
Dim FileArray()
DataFile = ThisWorkbook.Name
Workbooks(DataFile).ActiveSheet.Cells.ClearContents
With Application.FileSearch
.LookIn = ThisWorkbook.Path
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
For i = 1 To .FoundFiles.Count
If Dir(.FoundFiles(i)) <> DataFile Then
j = j + 1
ReDim FileArray(j)
FileArray(j) = Dir(.FoundFiles(i))
MyFile = ThisWorkbook.Path & Application.PathSeparator _
& FileArray(j)
MyRow = WorksheetFunction.CountA(Range("B:B"))
Application.ScreenUpdating = False
Workbooks.Open (MyFile)
MyMsg = MyMsg & vbCrLf & FileArray(j)
For jj = 2 To 32
For k = 2 To 28
Workbooks(DataFile). _
ActiveSheet.Cells(MyRow + jj, k) = _
Workbooks(FileArray(j)). _
Sheets("Giriş").Cells(jj, k)
Next
Next
Workbooks(FileArray(j)).Close
Application.ScreenUpdating = True
End If
Next
End If
Application.ScreenUpdating = True
End With
MsgBox MyMsg & vbCrLf & "Dosyalarından datalar alınmıştır !", vbInformation, "Rapor"
End Sub
[/vb:1:315e2dd628]

 

[selim_1]

Sayın Raider
Kodları denedim, sorunsuz ve istediğim gibi netice aldım.
Yalnız, Rapor sayfasının ilk başlık sütünnunu siliyor,onuda ben halletmeye çalışırım.
Çok teşekkür ediyorum.