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

 

[hüseyintok]

merhaba denermisiniz.

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

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
' dosya türü xlsm olanlardan ve dosya adı 2023 ile başlamayanlardan veri alacak
If fso.GetExtensionName(fls) = "xlsm" And Left(fls.Name, 4) <> "2023" Then
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

 

[hamitcan]

For Each fls In f
If Left(fls.Name, 4) = "2023" Then GoTo 10 ' Bu satırı ekledim

    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
10 ' Bu satırı ekledim
Next fls

 

[hamitcan]

İki satır ekledim. Basit örneği aşağıdaki gibi...

Sub nn()
If Left(fls.Name, 4) = "2023" Then GoTo 10


10
End Sub

 

[cengizyener]

Hüseyin Bey,

Çok teşekkür ederim kod tam istediğim gibi oldu elinize sağlık

 

[hüseyintok]

Hüseyin Bey,

Çok teşekkür ederim kod tam istediğim gibi oldu elinize sağlık

Güle güle kullanın

 

[cengizyener]

Hamitcan Bey,

Sizin göndermiş olduğunuz kodda dosya da başka yerde faydalanacağımı fark ettim sizin koduda orada kullanacağım çok teşekkür ederim yardımlarınız için

 

[cengizyener]

Güle güle kullanın

Teşekkür ederim Hüseyin Bey