Yalnız Mesajı Göster
Eski 10-11-2017, 13:07  
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,622
Excel Vers. ve Dili:
2010-2016
Varsayılan

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub askm_dosyalar()
Dim aktif As Workbook, sh As Worksheet, a As Long
Dim klasor As Object, evn As Object, xls As Object
    Set sh = ThisWorkbook.Worksheets("01.11.2017")
    Set evn = CreateObject("scripting.filesystemobject")
    Set klasor = evn.getfolder(ThisWorkbook.Path)
        For Each xls In klasor.Files
            If LCase(Mid(xls.shortname, InStr(1, xls.shortname, ".", 1) + 1)) = "xls" Then
            If xls.Name <> "ÖRNEK DOSYA.xls" Then
                Workbooks.Open (xls.Path)
                    Set aktif = ActiveWorkbook
                    Sayfa_ismi = Mid(aktif.Name, 2, 2) & "." & Mid(aktif.Name, 4, 2) & "." & Mid(aktif.Name, 6, 4)
                    Set sh = ThisWorkbook.Worksheets(Sayfa_ismi)
                    a = aktif.Sheets(1).Range("a65536").End(3).Row
                    aktif.Sheets(1).Range("a2:l" & a).Copy
                    sh.Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
                    aktif.Close False
            End If
            End If
        Next xls
    a = Empty
    Set sh = Nothing
    Set evn = Nothing
    Set aktif = Nothing
    Set klasor = Nothing
    MsgBox "Aktarma işlemi tamamlandı...", vbInformation, "ASKM"
End Sub
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla