Çözüldü Dosya İçerisindeki Sayfaları Tek Sayfaya Aktarma,

[gicimi]

Merhaba;

Masaüstünde bulunan bir klasör içerisindeki tüm satırları belirtilen kritere göre (Grup No) bilgisine göre aktarmak istiyorum.

A ile BH arası Hücrelerde veriler bulunmaktadır.
Toplam satır sayısı 1500 adettir.

Konu hakkında yardımcı olabilir misiniz. Teşekkürler.

 

[veyselemre]

Grup Noyu F1 e yazın.

Sub veriCek()
    Dim FSO As Object, strFolder As Object
    Dim strFile As Object
    Dim adoCN As Object, rs As Object
    Dim grup As String

    Set adoCN = CreateObject("ADODB.Connection")
    Set rs = CreateObject("Adodb.RecordSet")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open

    Set FSO = CreateObject("Scripting.FileSystemObject")

    grup = [f1].Value
    Rows("2:" & Rows.Count).ClearContents

    Set strFolder = FSO.GetFolder(ThisWorkbook.Path & "\Veriler")

    For Each strFile In strFolder.Files
        If LCase(FSO.GetExtensionName(strFile.Name)) = "xlsx" Then

            strSQL = "Select * From [Sayfa1$] IN '' [Excel 12.0;Database=" & strFile & _
                     "] WHERE [Grup No]=" & grup

            rs.Open strSQL, adoCN
            Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset rs
            rs.Close

        End If
    Next strFile
    Columns.AutoFit
    adoCN.Close
    Set rs = Nothing
    Set adoCN = Nothing
    Set strFolder = Nothing
    Set strFile = Nothing
    Set FSO = Nothing
End Sub

 

[gicimi]

@veyselemre hocam teşekkür ederim. Elinize sağlık