Soru Birden Fazla Excel Dosyasından Kapalı Halde Veri Çekme

[ultraslan38080]

İyi çalışmalar arkadaşlar.
Aşağıda 1 den 5 e kadar numaralandırılmış 5 adet excel dosyası var. Bu dosyaların içinde rastgele adet kadar veri mevcut. Bazısında 3 veri var, bazısında 5 veri var, bazısında veri yok vs vs.
Bu 5 adet excel dosyası içerisindeki verileri, düzgün bir sırayla ve bu 5 adet exceli açmadan, KANAK.xlsm dosyasına VBA/Makro ile otomatik olarak bir düğmeye basarak nasıl çekebiliriz.

İndir DOSYALAR

Dosyayı indir DOSYALAR

dosya.co

 

[Haluk]

Sub Test_ADO()
    'Haluk - 15/12/2020
    '
    Dim myFile As String, FileExt As String
    Dim FSO As Object, SourceFolder As Object
    Dim adoCN As Object
    Dim RS As Object
    Dim FileItem As Variant
    Dim NoA As Long
    Dim strFolder As String, strSQL As String
    
    Const adOpenKeyset = 1
    
    ActiveSheet.Range("A2:C" & Rows.Count) = ""
    
    strFolder = ThisWorkbook.Path

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(strFolder)
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
    RS.CursorType = adOpenKeyset
          
    For Each FileItem In SourceFolder.Files
        myFile = FileItem.Path
        FileExt = FSO.GetExtensionName(myFile)
        If FileExt = "xlsx" Then
            adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
            adoCN.Properties("Data Source") = myFile
            adoCN.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=No; IMEX=1"
            adoCN.Open
            
            strSQL = "Select * from [Sayfa1$A2:C]"
            On Error Resume Next
            RS.Open strSQL, adoCN
            If Err Then GoTo 10:
            Err.Clear
            NoA = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Range("A" & NoA).CopyFromRecordset RS
10:
            adoCN.Close
        End If
    Next
    
    MsgBox "İşlem tamam...!"
    
    Set RS = Nothing
    Set adoCN = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub

.

 

[ultraslan38080]

Çalıştı. Ne kadar teşekkür etsem azdır.