Bir çok kapalı excel dosyasından veri alma

[bebar]

Merhaba,

Daha önceden paylaşmış olduğunuz bir kod ile bir kapalı excel dosyasından veri alabiliyorum fakat birden fazla dosyadan veri alamıyorum.
aynı tablolardan oluşan m03 den başlayıp m41 e kadar giden excel dosyalarım mevcut. bunları aynı klasör içinde bulunan ana dosya adlı dosyaya sadece bir tanesinin verisini aşağıdaki gibi getirebiliyorum, kodları alt alta koymaya çalıştım fakat gene olmadı yardımcı olabilirseniz çok memnun olurum.



Sub KOD_OPEN_İLE()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim KK As Worksheet
Dim KA As Worksheet
Dim BUL


yol = ThisWorkbook.Path & "\m03.xlsm"
Workbooks.Open (yol)

Set KK = Workbooks("m03").Sheets("Sayfa1")
Set KA = Workbooks("ana dosya").Sheets("Sayfa1")

For i = 4 To KA.[A65536].End(3).Row

Set BUL = KK.Range("A:A").Find(KA.Cells(i, "A"), , xlValues, xlWhole)

If Not BUL Is Nothing Then

KA.Cells(i, "I") = KK.Cells(BUL.Row, "I")

End If

Next i

Workbooks("m03").Close False


Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Feedback raporunuz güncellenmiştir.", vbInformation, "Ürün yönetimi"

End Sub

 

[askm]

Örnek olarak Ana dosyanız ile diğer dosyalardan iki veya üç tanesini ekleyebilirseniz yardımcı olmaya çalışalım.

 

[bebar]

ana dosya adlı dosyada açıklamsını yaptım teşekkür ederim.

 

[asi_kral]

Merhaba
Bu kodu dener misiniz ?

Sub getir()
Dim KTP As Workbook, SYF As Worksheet, KPL As Excel.Application
Dim AKTP As Workbook, ASYF As Worksheet, STR As Long, YOL As String
Dim ARA As Range
Set AKTP = ActiveWorkbook
Set ASYF = AKTP.ActiveSheet
Set KPL = CreateObject("Excel.Application")
KPL.Visible = False
YOL = ThisWorkbook.Path & "\"
For STR = 4 To ASYF.Range("A" & Rows.Count).End(xlUp).Row
Set KTP = KPL.Workbooks.Open(YOL & ASYF.Range("B" & STR) & ".xlsm")
Set SYF = KTP.Sheets("Sayfa1")
Set ARA = SYF.Range("A:A").Find(ASYF.Range("A" & STR), , , xlWhole)
ASYF.Range("I" & STR) = SYF.Range("I" & ARA.Row)
If STR > 4 Then
If ASYF.Range("B" & STR) <> ASYF.Range("B" & STR - 1) Then
KTP.Close 0
End If: End If
Next
KTP.Close 0
End Sub

Umarım istediğiniz bilgileri getirir.

 

[bebar]

üstad süpersin çok teşekkür ederim.