Hücredeki adla eşit farklı klasör içindeki xls dosyaları sırasıyla açarak, içlerinden Vlookup ile data getirme sorunu

[jasmine10]

Kolay gelsin,
Elimde yaklaşık 500 excel dosyası var. Her birinde bir kelime karşılığındaki 3. sütundaki değeri (Vlookup ile) dosyaları açmadan, başka bir klasör altındaki ana excele getirmek istiyorum. (Kelime farklı satırlarda geçiyor). Dosyalarımın adları ana excelde birer hücrede yazılı (b2-b500). Değerler, yazılı olduğu hücrenin yanındaki hücrelere gelsin istiyorum (c2-c500). Makro B2'yi okuyup, o dosyayı varsa açmalı, yoksa "yok" yazmalı; vlookup ile kelimeyi aramalı bulduğu değeri C2 ye yazmalı, B3 teki dosyayı açtıktan sonra B2deki dosyayı kapatmalıdır.
Bütün dosyalarda Sheet 1 deki datalardan getirmek istiyorum.
Path'im şöyle: E:\DATA\EXCELLER\

EXCELLER Dosyası altında tek kelimeden oluşan ve adları ana excelde B2-b500 arasında bulunan excel dosyaları var. Fakat excel sayısı 300 civarında. Yani ana exceldeki her dosya adı maalesef mevcut değil.

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

 

[jasmine10]

Sub LoopThroughFolder()
Dim c As Range, MyRng As Range
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rng As Range, sh As Worksheet

Set Wb = ThisWorkbook
Set sh = Wb.Sheets(1) 'first sheet in workbook

MyDir = "C:\Users\davem\Downloads\WorkBookLoop\" 'change the address to suite
Application.ScreenUpdating = False
Application.DisplayAlerts = False

With sh
Set MyRng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
For Each c In MyRng.Cells

MyFile = Dir(MyDir & c & ".xls") 'change file extension
ChDir MyDir

Workbooks.Open (MyFile)

With Worksheets("Sheet1")
Set Rng = .Cells.Find("NÜFUS")
If Not Rng Is Nothing Then
With sh
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).Value = Rng.Offset(, 3).Value
End With
End If
ActiveWorkbook.Close True
End With

MyFile = Dir()
Next c

End With

Wb.Save
End Sub


Bunu yazdım ama çalışmıyor. Hatam galiba olmayan dosyaların adlarında takılması. Ama çözemedim. Bir yardım rica ediyorum.