https://resim.accesstr.net/do.php?img=10999
Sub GetData()
Dim sFile As Workbook, tFile As Workbook
Dim dosya As String, kes, parcaAl, son As Long
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Set tFile = ThisWorkbook
Set s1 = tFile.Sheets("İzin")
Set s2 = tFile.Sheets("Rapor")
Set s3 = tFile.Sheets("Ücretsiz")
Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls*")
s1.Cells.ClearContents: s2.Cells.ClearContents: s3.Cells.Clear
Do While dosya <> ""
If dosya <> ThisWorkbook.Name Then
Set sFile = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & dosya)
kes = Split(dosya, ".")
parcaAl = Mid(dosya, 1, Len(dosya) - Len(kes(UBound(kes))) - 1)
If parcaAl Like "İzin*" Then
son = sFile.Worksheets("İzin").Cells(Rows.Count, 1).End(3).Row
sFile.Worksheets("İzin").Range("A1:E" & son).Copy s1.Cells(1, 1)
ElseIf parcaAl Like "Rapor*" Then
son = sFile.Worksheets("Rapor").Cells(Rows.Count, 1).End(3).Row
sFile.Worksheets("Rapor").Range("A1:AA" & son).Copy s2.Cells(1, 1)
ElseIf parcaAl Like "Ücretsiz*" Then
son = sFile.Worksheets("Ücretsiz").Cells(Rows.Count, 1).End(3).Row
sFile.Worksheets("Ücretsiz").Range("A1:K" & son).Copy s3.Cells(1, 1)
End If
kes = "": sFile.Close
End If
Application.CutCopyMode = False
dosya = Dir
Loop
Application.ScreenUpdating = True
s1.Activate
s1.Cells(1, 1).Activate
MsgBox "Bitti"
Set sFile = Nothing: Set tFile = Nothing: parcaAl = vbNullString
Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
End Sub