08/05/2021, 00:09
Sayın @feraz beyin ve @atoykan beyin yardımları ile son aşamasına geldiğim dosyamdaki macro ile ilgili olarak;
Veri aldığım kitaplar İzin, Rapor ve Ücretsiz'dir. Aynı şekilde de içindeki sayfa isimleri de aynı;
Sistemden veri aldığım zaman kitap isimlerine ve sayfa isimlerine numara ekleniyor Örneğin İzin kitabı önce İzin77 ise İzin78 olarak içerisindeki sayfa adı da önce İzin77, sonra İzin78 olarak geliyor.
Kitap ve Sayfa isimlerini değiştirirsem Kitap: İzin Sayfa: İzin yaparsam aşağıdaki macro çalışıyor.
Macro üzerinde bir değişiklik yapılıp da örneğin; Kitap için : İzin*.*, Sayfa için : İzin*.* gibi değişken özelliği eklenebilir mi? Bu kısmı düzenleyemedim. Yardımcı olabilecek arkadaşlara teşekkürler. Aşağıdaki macro üzerinde değişiklik yapılabir mi?
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("İzin")
Set s2 = tFile.Sheets("Rapor")
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 = "İzin" Then
sFile.Worksheets("İzin").Range("A1").CurrentRegion.Offset(1).Copy _
s1.Cells(Rows.Count, 1).End(3).Offset(1, 0)
Application.CutCopyMode = False
ElseIf parcaAl = "Rapor" Then
sFile.Worksheets("Rapor").Range("A1").CurrentRegion.Offset(1).Copy _
s2.Cells(Rows.Count, 1).End(3).Offset(1, 0)
Application.CutCopyMode = False
ElseIf parcaAl = "Ücretsiz" Then
sFile.Worksheets("Ücretsiz").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
Sheets("TümVeri").Select
Range("AT2").Select
MsgBox "Veri aktarma işlemi bitti."
Set sFile = Nothing: Set tFile = Nothing: parcaAl = vbNullString
Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
End Sub
Veri aldığım kitaplar İzin, Rapor ve Ücretsiz'dir. Aynı şekilde de içindeki sayfa isimleri de aynı;
Sistemden veri aldığım zaman kitap isimlerine ve sayfa isimlerine numara ekleniyor Örneğin İzin kitabı önce İzin77 ise İzin78 olarak içerisindeki sayfa adı da önce İzin77, sonra İzin78 olarak geliyor.
Kitap ve Sayfa isimlerini değiştirirsem Kitap: İzin Sayfa: İzin yaparsam aşağıdaki macro çalışıyor.
Macro üzerinde bir değişiklik yapılıp da örneğin; Kitap için : İzin*.*, Sayfa için : İzin*.* gibi değişken özelliği eklenebilir mi? Bu kısmı düzenleyemedim. Yardımcı olabilecek arkadaşlara teşekkürler. Aşağıdaki macro üzerinde değişiklik yapılabir mi?
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("İzin")
Set s2 = tFile.Sheets("Rapor")
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 = "İzin" Then
sFile.Worksheets("İzin").Range("A1").CurrentRegion.Offset(1).Copy _
s1.Cells(Rows.Count, 1).End(3).Offset(1, 0)
Application.CutCopyMode = False
ElseIf parcaAl = "Rapor" Then
sFile.Worksheets("Rapor").Range("A1").CurrentRegion.Offset(1).Copy _
s2.Cells(Rows.Count, 1).End(3).Offset(1, 0)
Application.CutCopyMode = False
ElseIf parcaAl = "Ücretsiz" Then
sFile.Worksheets("Ücretsiz").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
Sheets("TümVeri").Select
Range("AT2").Select
MsgBox "Veri aktarma işlemi bitti."
Set sFile = Nothing: Set tFile = Nothing: parcaAl = vbNullString
Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
End Sub