Çalışma Sayfalarını Topluca Birleştirmek İstiyorum

[sonageldik]

Selamlar kolay gelsin. Öncelikle forumda arama yaptığımı bulduğum sonuçlardan verim alamadığımı belirteyim. Ofis2013 kullanıyorum

Elimde Aynı sütun ve satır biçimlerine sahip birkaç yüz tane çalışma kitabı var. Bunları tek bir excell çalışma kitabına birleştirmek istiyorum. Tüm çalışma kitaplarını alta alta sütun yada satır kaybı olmadan eklesin ve birleştirsin istiyorum.

Yardımınıza şimdiden teşekkür ederim.

 

[PLİNT]

Selamlar kolay gelsin. Öncelikle forumda arama yaptığımı bulduğum sonuçlardan verim alamadığımı belirteyim. Ofis2013 kullanıyorum

Elimde Aynı sütun ve satır biçimlerine sahip birkaç yüz tane çalışma kitabı var. Bunları tek bir excell çalışma kitabına birleştirmek istiyorum. Tüm çalışma kitaplarını alta alta sütun yada satır kaybı olmadan eklesin ve birleştirsin istiyorum.

Yardımınıza şimdiden teşekkür ederim.

Merhaba
Aşağıdaki adresten Sn Orion 1 'in kodlarını deneyin,
http://www.excel.web.tr/f48/kapaly-dosyalardan-veri-cekmek-t145845.html

Konudaki örnek

 

[sonageldik]

Merhaba
Aşağıdaki adresten Sn Orion 1 'in kodlarını deneyin,
http://www.excel.web.tr/f48/kapaly-dosyalardan-veri-cekmek-t145845.html

Konudaki örnek

  Private Sub CommandButton1_Click()
Dim ds, dc, f, s
Call Excel.ActiveSheet.UsedRange.ClearContents
Call Excel.ActiveSheet.UsedRange.ClearFormats
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\KLASÖR")
Set dc = f.Files

 '   Application.ScreenUpdating = False

For Each DOSYA In dc
With ActiveSheet.QueryTables.Add(Connection:= _
Array("OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & DOSYA & ";Jet OLEDB:Engine Type=35;;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk ", _
"Transactions=1"), _
Destination:=Cells(ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row + 1, 1))
        .CommandType = xlCmdTable
        .CommandText = Array("Sayfa1$")
        .RefreshStyle = xlOverwriteCells
        .SourceDataFile = DOSYA
        .Refresh BackgroundQuery:=False
    End With
   
    Cells(ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row, 1).Select
    Next
    
     'Application.ScreenUpdating = True
End Sub

bunu kullandım ancak path not found uyarısı alıyorum. Dosya yolunu tam yazdığım halde uyarı vermeye devam ediyor

 

[PLİNT]

Evren beyin kodlarını deneyecektiniz
Örneği buradan indirip deneyin:
http://s4.dosya.tc/server/y4tc58/kapali_dosya.zip.html

Sub adoverial59()
Dim conn As Object, rs As Object, dosya As String, i As Long
Dim sonsat As Long, yol As String
Sheets("Sayfa1").Select
Range("A2:L" & Rows.Count).ClearContents
sonsat = 2
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
yol = ThisWorkbook.Path & "\DATALAR\"
dosya = Dir(yol & "*.xlsx")
Application.ScreenUpdating = False
Do While dosya <> ""
    conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & yol & dosya & ";extended properties=""excel 12.0;hdr=yes;imex=1"""
    rs.Open "select * from [Sayfa1$];", conn, 1, 1
    Range("A" & sonsat).CopyFromRecordset rs
    sonsat = Cells(Rows.Count, "A").End(xlUp).Row + 1
    rs.Close: conn.Close
    dosya = Dir
Loop
Set rs = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[Asri]

Alternatif leri deneyiniz.

http://asriakdeniz.com/tum-excel-sayfalarini-bir-sayfada-toplama-belirli-bir-sayfa-icin
http://asriakdeniz.com/tum-excel-dosyalarini-tek-sayfaya-kopyalama

 

[sonageldik]

Alternatif leri deneyiniz.
http://asriakdeniz.com/tum-excel-dosyalarini-tek-sayfaya-kopyalama

Desteğiniz için teşekkür ederim. Bu bağlantıdaki çalışma satır, sütun veri kaybı vs. hiçbir sıkıntı çıkarmadan işimi gördü. Başarılar k::