Klasör İçerisindeki 3 Yardımcı Kitaptan Ana Kitaba Veri Aktarımı

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

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.

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

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

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.

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