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

İzin ibarelerini kaldırayım Dr.Raporu, Senelik, Ücretsiz olarak düzelteyim/düzeltip o şekilde uyarlayabilir misiniz?

Son dosyanıza göre alttaki kod çalışıyor.Tabii kalasördeki gibi isimlerle başlaması gerek.

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 "*Senelik " & syfizin & "*" Then

                  syfparca.Range("A1").CurrentRegion.Copy s1.Cells(1, 1)

                ElseIf parcaAl Like "*Dr." & syfRapor & "*" Then

                    syfparca.Range("A1").CurrentRegion.Copy s2.Cells(1, 1)

                ElseIf parcaAl Like "*" & syfucretsiz & " Ýzin*" Then

                    syfparca.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: parcaAl = vbNullString

    Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing: Set syf = Nothing

End Sub

---

(08/05/2021, 22:40)yyhy yazdı: İzin ibarelerini kaldırayım Dr.Raporu, Senelik, Ücretsiz olarak düzelteyim/düzeltip o şekilde uyarlayabilir misiniz?

Bence daha garanti olur abey.

Sayın @feraz bey dosya içerisine kodu yerleştirip ana dosyayı buraya ekleyebilir misiniz? Bir terslik var kusura bakmayın kodu aldım bir yerde hata yapıyorum.

(08/05/2021, 23:00)yyhy yazdı: Sayın @feraz bey dosya içerisine kodu yerleştirip ana dosyayı buraya ekleyebilir misiniz? Bir terslik var kusura bakmayın kodu aldım bir yerde hata yapıyorum.

Tamam abey dışarı çıkıyorum gelince eklerim.

Abey dosya ekte.
Dikkat edilmesi gerekenler alttaki gibi baslaması gerek klasördeki Excel isimleri

Senelik İzin ve Ücretsiz İzin buralarda harfler arasında boşluk olmsada olur koda replace ekledim.

Senelik İzin
Ücretsiz İzin
Dr.Rapor

Teşekkürler emeğinize sağlık.