Alt klasörler altında bulup, dosyayı excel içine alma

[cengiz123]

Merhabalar

c sürücüsü altında, dosyalar klasörü var. Dosyalar klasörü altında 4-5 alt klasör var. Bu alt klsörler içinde excel dosyaları var. Soruma gelecek olursak;

Excel dosyamda(Adırogram.xlsm)sayfa1 de A1 hücresine dosya ismi giriyorum.girdiğim değer bir dosyanin ismi. Butona bastığımda C\Dosyalar altında arama yapacak ve bulduğu excel dosyasının ilk sayfasını (komple sayfa halinde), butona bastığım çalışma kitabına (Program.xlsm'ye) kopyalayacak.

Yardım ve destekleriniz için şimdiden çok teşekkür ederim

 

[askm]

Örnek dosya eklemeniz halinde çözüme daha çabuk ulaşırsınız.

 

[cengiz123]

merhaba Askm hocam
ilginiz için çok teşekkür ederim.
örnek dosya aşağıdadır
şimdiden teşekkürler
https://www.dosyaupload.com/hQqS

 

[askm]

İşyerinde upload linklerinden dosya indiremiyorum. Akşam bakmaya çalışacağım. Bu arada başka birisi de ilgilenebilir belki.

 

[cengiz123]

Merhabalar
Konuyla ilgili yardımcı olabilecek var mıdır?

 

[cengiz123]

Merhaba askm hocam
Rica etsem yardımcı olabilir misiniz

 

[cengiz123]

Merhabalar
Konuyla ilgili yardımcı olabilecek var mıdır

 

[Zeki Gürsoy]

Deneyin...

[SIZE=2]Sub BulveYukle()
    Dim InitialPath As String, fld As Object, d As String
    Dim wb1 As Workbook, wb2 As Workbook
    
    Set wb1 = ThisWorkbook
    
    InitialPath = ThisWorkbook.Path & "\Dosyalar"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each fld In CreateObject("Scripting.FileSystemObject").GetFolder(InitialPath).SubFolders
        
        d = Dir(InitialPath & "\" & fld.Name & "\" & wb1.Worksheets(1).[a1] & ".xlsx")
        
        Do While d <> ""
            
            Set wb2 = Workbooks.Open(InitialPath & "\" & fld.Name & "\" & d)
            
            If ShExist(fld.Name & "_" & wb1.Worksheets(1).[a1]) Then _
                wb1.Worksheets(fld.Name & "_" & wb1.Worksheets(1).[a1]).Delete
            
            wb2.Worksheets(1).Copy After:=wb1.Worksheets(wb1.Worksheets.Count)
            
            wb1.Worksheets(wb1.Worksheets.Count).Name = fld.Name & "_" & wb1.Worksheets(1).[a1]
            
            wb2.Close False
            
            d = Dir
            
        Loop
        
    Next
    
    wb1.Worksheets(1).Activate
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Private Function ShExist(shname) As Boolean
    Dim sh As Worksheet
    
    For Each sh In ThisWorkbook.Worksheets
    
        If StrComp(sh.Name, shname, vbTextCompare) = 0 Then
        
            ShExist = True
            
            Exit For
        
        End If
        
    Next
    
End Function[/SIZE]

.

 

[cengiz123]

Zeki Hocam merhaba
Harika olmuş. Çok teşekkür ederim. Ayrıca kod çok hızlı çalışıyor.
Elinize sağlık tekrardan