Option Explicit
Sub DOSYALARDAN_VERİ_AL()
Dim K1 As Workbook, K2 As Workbook
Dim K3 As Workbook, S1 As Worksheet
Dim X As Integer, Satır As Integer, Son_Satır As Long
Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçiniz...", 50, &H0)
If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
ElseIf Not Klasör Is Nothing Then
Kaynak_Klasör = Klasör.Items.Item.Path
Else
MsgBox "İşleme devam edebilmek için klasör seçimi yapmalısınız!" & Chr(10) & _
"İşleminiz iptal edilmiştir.", vbCritical
Exit Sub
End If
On Error Resume Next
Set K1 = ThisWorkbook
Set K2 = Workbooks.Add(1)
Dosya = Dir(Kaynak_Klasör & "\*.xls")
Satır = 2
Application.ScreenUpdating = False
Do
If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
DoEvents
Application.DisplayAlerts = False
Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
Application.DisplayAlerts = True
Set S1 = K3.Sheets(1)
Son_Satır = S1.Cells(Rows.Count, 2).End(3).Row
S1.Range("B2:M" & Son_Satır).Copy
K2.Sheets("Sayfa1").Range ("A" & Satır)
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""
K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
K2.Close True
Set K1 = Nothing
Set K2 = Nothing
Set K3 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub