Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Alt klasörler altında bulup, dosyayı excel içine alma (http://www.excel.web.tr/showthread.php?t=170363)

cengiz123 06-02-2018 22:43

Alt klasörler altında bulup, dosyayı excel içine alma
 
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ı:Program.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 07-02-2018 07:36

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

cengiz123 08-02-2018 00:54

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 08-02-2018 07:16

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

cengiz123 08-02-2018 23:49

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

cengiz123 09-02-2018 21:58

Merhaba askm hocam
Rica etsem yardımcı olabilir misiniz

cengiz123 10-02-2018 13:14

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

Zeki Gürsoy 10-02-2018 16:49

Deneyin...

Kod:

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

.

cengiz123 11-02-2018 00:39

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


Saat 04:04

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.