Makroda Belirli Dosyalardan Veri Almasın

[cengizyener]

Merhabalar Arkadaşlar,

Aşağıda belirli klasördeki sonu .xlsm olan dosyalardaki verileri alıyorum. Fakat 2023 ile başlayan dosyaları da almasını istemiyorum bunun için kodda ne gibi bir güncelleme yapmam lazım yardımcı olur musunuz ?

Kod:

Sub Birlestir()

Sheets("Tümİmalat").Select

Range("A5:AC65536").ClearContents ' veri yenilendiğinde hangi alanların delete tuşu gibi silineeceğini gösteriyor

Dosyalarin_bulundugu_klasoru_sec

Application.ScreenUpdating = False 'Eğer ekrana yazmaya başlamadan önce false yaparsanız ekrana yazmaz ama hafızaya yazar.en sonunda true yaptığınızda ise hafızada yazılı olanları excele yazar

If [BM1] = "" Then End

Dim t, dosyasay As Integer

Dim fso As Object, f As Object, dosya As String, kaynak As String, fls As Object

Dim sonsatir As Long, sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.getfolder([BM1]).Files

dosyasay = 0

ThisWorkbook.Activate

ThisWorkbook.Sheets("Tümİmalat").Select

For Each fls In f

    If fso.GetExtensionName(fls) = "xlsm" Then 'dosya türü xlsm olanlardan veri alacak

        If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False

        'For Each sh In Workbooks(fls.Name).Worksheets

            sonsat1 = Sheets("Üretim Listesi").Cells(65536, "F").End(xlUp).Row

            If sonsat1 > 4 Then ' Son dolu satır 4 ten büyükse verileri aktarıyor

                liste = Sheets("Üretim Listesi").Range("A5:AC" & sonsat1).Value

                sonsat2 = ThisWorkbook.Sheets("Tümİmalat").Cells(65536, "B").End(xlUp).Row + 1

                ThisWorkbook.Sheets("Tümİmalat").Range("A" & sonsat2).Resize(UBound(liste), 29) = liste

                Erase liste

            End If

        'Next sh

        dosyasay = dosyasay + 1

        Workbooks(fls.Name).Close False

    End If

Next fls

ThisWorkbook.Activate

ThisWorkbook.Sheets("Tümİmalat").Select

Application.ScreenUpdating = True

Sheets("Kaynak").Select

Range("A1").Select

MsgBox dosyasay & " adet dosyadaki bilgiler Programa aktarildi."

End Sub



Sub Dosyalarin_bulundugu_klasoru_sec()

Dim kaynak As String

[BM1].Clear

'aşağıdaki yeşil renkli kodlar klasörün seçim yapılarak alınması için kullanılacak kodlardır.

'Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Dosyalarin bulundugu Klasoru Secin", 50, &H0)

'If Not Klasor Is Nothing Then

kaynak = "\\192.168.1.201\uretim\ÜRETİM RAPORLARI"

'kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path

[BM1] = kaynak



'End If

End Sub