Çok teşekkür ederim. İyi geceler iyi sahurlar emek verdiniz hakkınızı ödeyemeyiz.

(07/05/2021, 02:13)yyhy yazdı: Çok teşekkür ederim. İyi geceler iyi sahurlar emek verdiniz hakkınızı ödeyemeyiz.

Rica ederim abey,sizede hayırlı sahurlar.Hakkım tüm üyelere Helaldir

Konya'dan selam saygı ve dua ile...

Alttaki gibide kullanabilirsiniz abey.
Sayfa askları ile başlıyorsa eklendi ve currentregion yerine tüm hücreler kopyanandırıldı.

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 & "*.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 "Liste1(Senelik Mazeret)*" Then

                    sFile.Worksheets("Sayfa1").Cells.Copy s1.Cells(1, 1)

                ElseIf parcaAl Like "Liste2(Dr.Raporlu Sevk)*" Then

                    sFile.Worksheets("Sayfa1").Cells.Copy s2.Cells(1, 1)

                ElseIf parcaAl Like "Liste3(Ücretsiz)*" Then

                    sFile.Worksheets("Sayfa1").Cells.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

Yada sayfadaki sütunlar sabitse alttakide olabilir.
Daha fazla Excel dosyası varsa function ile kısatlılabilir.
ya bunu kullanın yada önceki mesajdakini bence.
currentregion olayı biraz garip ben kullanmıyorum lakin izlediğim videolarda bunu kullanıyorlar kod kısa olsun diye.

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("Senelik Mazeret")

Set s2 = tFile.Sheets("Dr.Raporlu Sevk")

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 "Liste1(Senelik Mazeret)*" Then

                    son = sFile.Worksheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row

                    sFile.Worksheets("Sayfa1").Range("A1:E" & son).Copy s1.Cells(1, 1)

                ElseIf parcaAl Like "Liste2(Dr.Raporlu Sevk)*" Then

                    son = sFile.Worksheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row

                    sFile.Worksheets("Sayfa1").Range("A1:AA" & son).Copy s2.Cells(1, 1)

                ElseIf parcaAl Like "Liste3(Ücretsiz)*" Then

                    son = sFile.Worksheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row

                    sFile.Worksheets("Sayfa1").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

Currentregion için garip dediğm olayıda gif ile gösterdim.


https://resim.accesstr.net/do.php?img=10995