Merhaba.
Atoykan hocamızın kodunu alttaki gibi düzenledim.
Sub GetData()
Dim sFile As Workbook, tFile As Workbook
Dim dosya As String
Set tFile = ThisWorkbook
Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.*")
With tFile.Worksheets("Senelik Mazeret")
.Range("A2:E" & Rows.Count).ClearContents
Do While dosya <> ""
If dosya <> ThisWorkbook.Name Then
Set sFile = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & dosya)
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy
.Activate
.Cells(Rows.Count, 1).End(3).Offset(1, 0).Select
.Paste
Application.CutCopyMode = False
sFile.Close
End If
dosya = Dir
Loop
Set sFile = Nothing
Set tFile = Nothing
Application.ScreenUpdating = True
ThisWorkbook.Activate
.Activate
.Range("A1").Select
End With
MsgBox "Bitti"
End Sub
Gerçi mantık hatası var ayarlayınca eklerim.
Sayfa1 yazmışsınız ondan kafalar karıştı.
Alttaki kod işinizi görür.Çalışmazsa Tr karakterlerini düzeltin.
Sub GetData()
Dim sFile As Workbook, tFile As Workbook
Dim dosya As String, kes, parcaAl
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Set tFile = ThisWorkbook
Set s1 = tFile.Sheets("Senelik Mazeret")
Set s2 = tFile.Sheets("Dr.Raporlu Sevk")
Set s3 = tFile.Sheets("Ücretsiz")
Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.*")
With s1
.Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
End With
With s2
.Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
End With
With s3
.Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)).ClearContents
End With
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 = "Liste1(Senelik Mazeret)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy _
s1.Cells(Rows.Count, 1).End(3).Offset(1, 0)
Application.CutCopyMode = False
ElseIf parcaAl = "Liste2(Dr.Raporlu Sevk)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy _
s2.Cells(Rows.Count, 1).End(3).Offset(1, 0)
Application.CutCopyMode = False
ElseIf parcaAl = "Liste3(Ücretsiz)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy _
s3.Cells(Rows.Count, 1).End(3).Offset(1, 0)
Application.CutCopyMode = False
End If
Application.CutCopyMode = False
sFile.Close
End If
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
Sadece deger ve formatlar kopyalansın derseniz koddaki ilgili yerleri alttaki gibi değiştirin.
If parcaAl = "Liste1(Senelik Mazeret)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy
s1.Cells(Rows.Count, 1).End(3).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
ElseIf parcaAl = "Liste2(Dr.Raporlu Sevk)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy
s2.Cells(Rows.Count, 1).End(3).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
ElseIf parcaAl = "Liste3(Ücretsiz)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Offset(1).Copy
s3.Cells(Rows.Count, 1).End(3).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End If
Bu kodda başlıklarla birlikte alır verileri.
Kolay gelsin.
Sub GetData()
Dim sFile As Workbook, tFile As Workbook
Dim dosya As String, kes, parcaAl
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Set tFile = ThisWorkbook
Set s1 = tFile.Sheets("Senelik Mazeret")
Set s2 = tFile.Sheets("Dr.Raporlu Sevk")
Set s3 = tFile.Sheets("Ücretsiz")
Application.ScreenUpdating = False
dosya = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.*")
s1.Cells.ClearContents: s2.Cells.ClearContents: s3.Cells.ClearContents
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 = "Liste1(Senelik Mazeret)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Copy s1.Cells(1, 1)
ElseIf parcaAl = "Liste2(Dr.Raporlu Sevk)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.Copy s2.Cells(1, 1)
ElseIf parcaAl = "Liste3(Ücretsiz)" Then
sFile.Worksheets("Sayfa1").Range("A1").CurrentRegion.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
Tamam @
feraz bey deneyip bilgi vereyim. Teşekkür ederim.
Sayın @
feraz bey uzantı ile ilgi bir şey göremedim ama *.* olarak mı ayarladınız? Şuan sorun yok güzel çalışıyor. Emeğinize sağlık. @
atoykan beye de teşekkür ederim. Son noktayı siz koydunuz. Emeğinize sağlık.
*.* bu tüm dosya uzantılarını arar abey *.xlsm* yaparsanız ona göre arar.
Rica ederim.