Ýzin gibi çıktığı için oraları düzeltin kodda.
"Rapor*" yerine "*Rapor*" olarak değiştirisenizde içerirse olarak arar.
Sub GetData()
Dim sFile As Workbook, syfparca As Worksheet
Dim dosya As String, kes, parcaAl
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Const syfizin As String = "Ýzin*"
Const syfRapor As String = "Rapor*"
Const syfucretsiz As String = "Ücretsiz*"
Dim syf As Worksheet
For Each syf In ThisWorkbook.Worksheets
If syf.Name Like syfizin Then
Set s1 = syf: s1.Cells.Clear
ElseIf syf.Name Like syfRapor Then
Set s2 = syf: s2.Cells.Clear
ElseIf syf.Name Like syfucretsiz Then
Set s3 = syf: s3.Cells.Clear
End If
Next
Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls*")
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)
Set syfparca = Workbooks(parcaAl).Sheets("Sayfa1")
If parcaAl Like syfizin Then
syfparca.Range("A1:E" & syfparca.Cells(syfparca.Rows.Count, 1).End(3).Row).Copy s1.Cells(1, 1)
ElseIf parcaAl Like syfRapor Then
syfparca.Range("A1:AA" & syfparca.Cells(syfparca.Rows.Count, 1).End(3).Row).Copy s2.Cells(1, 1)
ElseIf parcaAl Like syfucretsiz Then
syfparca.Range("A1:K" & syfparca.Cells(syfparca.Rows.Count, 1).End(3).Row).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: parcaAl = vbNullString
Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing: Set syf = Nothing
End Sub
