Re: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - yyhy - 08/05/2021
Sayın @feraz bey Kitap isimlerini değiştirdim çalışıyor. Sayfa adlarına ek yaptığım adını değiştirdiğim zaman çalışmıyor. Son düzenlediğim macro sizin en son attığınız ve benim uyarladığım aşağıdaki gibi acaba hata nerededir?
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
RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021
Tamam abey resme baktım halledince eklerim kodu.
Son dosyalarınızı eklemeniz gerekiyor hatalı şekilde ve klasörde exceller olacak şekilde çünkü değiştirmişsiniz.
Re: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021
Alttaki gibi deneyin sanırım dosya eklemeniz için zamanınız yok.
Ý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
RE: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021
syfparca.Range("A1:K" & syfparca.Cells(syfparca.Rows.Count, 1).End(3).Row).Copy
Yukardaki gibilerin yerine alttakide olur.
syfparca.Range("A1").currentregion.offset(1).copy
Re: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - yyhy - 08/05/2021
Sayın @feraz bey inanın son aşamaya geldim önceki sefer yazdığımda dosya eklememişim. Kodu bir türlü uyarlayamadım. İçerisinde kişisel bilgi olmayan asıl ana dosyam ile örnek dosyaları ekliyorum acaba bir deneyip foruma yükleme şansınız var mı acaba? Dosya ekleyemedim link olarak attım.
Ayrıca kitap isimleri ve sayfa isimleri joker karakter kullanabilirsek özellikle sayfa adında çok iyi olacak.
Re: Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı - feraz - 08/05/2021
Abey dosyanın çalışmaması normal çünkü resimdeki gibi exceladları farklı ile başlar yerine içerik olarak aratsak bukezde iki dosyada izin olarak geçiyor.
https://resim.accesstr.net/do.php?img=11000
|