Dosyaları birleştirmek

[ASLAN7410]

Merhaba hayırlı geceler.

Masa üstünde ÇALIŞMA isimli bir klasörüm var, bu klasör içerisinde A ile başlayan
dosyalar, B ile başlayan dosyalar ve SONUÇ isimli dosyam var.

Benim istediğim ÇALIŞMA klasörü içindeki SONUÇ isimli dosyadaki A ile başlayan
dosyaları yapıştır butonuna bastığımda ÇALIŞMA klasörü içindeki A ile başlayan dosyaları
SONUÇ dosyasının A sayfasına alt alta yapıştırsın.

B ile başlayan dosyaları yapıştır butonuna bastığımda yukarıdaki işlemin aynısını B sayfasına alt alta yapıştırsın.

Forumda çok örnekler var ancak bu kodları kendi sayfalarıma uyarlıyamadım.

Yardımcı olur musunuz?

 

[askm]

Aşağıdaki kodları bir modüle yapıştırıp butona atayın.

Sub dosyalar_A()
Dim aktif As Workbook, sh As Worksheet, a As Long
Dim klasor As Object, evn As Object, xls As Object
    Set sh = ThisWorkbook.Worksheets("A")
    Set evn = CreateObject("scripting.filesystemobject")
    Set klasor = evn.getfolder(ThisWorkbook.Path)
        For Each xls In klasor.Files
            If LCase(Mid(xls.shortname, InStr(1, xls.shortname, ".", 1) + 1)) = "xls" Then
            If xls.Name <> "SONUÇ.xls" And Left(xls.Name, 1) = "A" Then
                Workbooks.Open (xls.Path)
                    Set aktif = ActiveWorkbook
                    a = aktif.Sheets(1).Range("a65536").End(3).Row
                    aktif.Sheets(1).Range("a2:l" & a).Copy
                    sh.Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
                    aktif.Close False
            End If
            End If
        Next xls
    a = Empty
    Set sh = Nothing
    Set evn = Nothing
    Set aktif = Nothing
    Set klasor = Nothing
End Sub

Sub dosyalar_B()
Dim aktif As Workbook, sh As Worksheet, a As Long
Dim klasor As Object, evn As Object, xls As Object
    Set sh = ThisWorkbook.Worksheets("B")
    Set evn = CreateObject("scripting.filesystemobject")
    Set klasor = evn.getfolder(ThisWorkbook.Path)
        For Each xls In klasor.Files
            If LCase(Mid(xls.shortname, InStr(1, xls.shortname, ".", 1) + 1)) = "xls" Then
            If xls.Name <> "SONUÇ.xls" And Left(xls.Name, 1) = "B" Then
                Workbooks.Open (xls.Path)
                    Set aktif = ActiveWorkbook
                    a = aktif.Sheets(1).Range("a65536").End(3).Row
                    aktif.Sheets(1).Range("a2:l" & a).Copy
                    sh.Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
                    aktif.Close False
            End If
            End If
        Next xls
    a = Empty
    Set sh = Nothing
    Set evn = Nothing
    Set aktif = Nothing
    Set klasor = Nothing
End Sub

 

[ASLAN7410]

Sayın askm ilginiz için çok teşekkür ederim, ellerinize sağlık.

Akşamları çalıştığım için bilgisayar başına yeni geçebildim.

Yazmış olduğunuz kod gayet güzel çalışıyor ancak, butona bastığımda her yapıştırma
yaptığında aşağıda gönderdiğim uyarı mesajları geliyor, bu mesajları iptali için kod içine ekleyebilir miyiz?

 

[ASLAN7410]

Sayın askm ÇALIŞMA klasörü içerisinde örnek olarak bazen A ve B ile başlayan excel
dosyaları 20 tane oluyor, bazende daha fazla oluyor.

Butonla A ve B isimli dosyaları yapıştır dediğimde 20 sefer veya daha fazla olarak 3 nolu
mesajımda gönderdiğim uyarı mesajına hayır diyorum, bu mesajın gelmemesi için kod içerisine yazabilir misiniz?

 

[ASLAN7410]

Sayın askm gerçekten uzun uğraşlar sonucunda aşağıdaki kodları buldum, yazmış olduğunuz
kodların başına ve sonuna eklediğinde herhangi bir uyarı mesajı ekrana gelmiyor.

Belki başkaları da faydalanır diye paylaşmak istedim.

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'kendi kodlarınız

Application.DisplayAlerts = True
Application.ScreenUpdating = True

 

[askm]

Akşamları bilgisayar başında olamıyorum bakamadım kusura bakmayın. Belirttiğiniz kodlar hızlandırma kodları olarak da geçer. Birinci kod ekran yenilemeyi, ikinci kod ise uyarıları göstermeyi iptal eder. Kod bittikten sonra da bunları açmış oldunuz.