Excel Dosyasındaki Verileri bir Dosyada Birleştirmek

[eewwrree]

Arkadaşlar, Hayırlı geceler.


İş yerinde bir klasör içerisinde Çalışma Dosyası adı ile Çalışma Sayfası adı aynı olan ayrı ayrı 1000'e yakın dosya var. Bu dosyaların A2, B2, C2, D2, E2 hücrelerinin içerikleri aynı.Bu dosyaları farklı bir dosya altında birleştirmek istiyorum.

Ekte örnekler mevcut. İşlem öncesi Tümü Boş dosyası iken işlemden sonra Tümü Dolu hale gelecek.

Arkadaşlar acil. lütfen yardım edin

 

[mancubus]

web'den, bir excel gurusundan örnek:
Tümü Dolu.xls dosyasında standart bir modüle kopyalayarak deneyin.
önce 5-6 dosyanızı deneme amaçlı olarak oluşturacağınız bir klasöre kopyalayarak test edin. (kodda bu klasörün yolunu fPath değişkeninee atamayı unutmayın. deneme başarılı olursa bu değişkene gerçek klasörü atar ve çalıştırısınız.)

Option Explicit

Sub Consolidate()
'http://www.excelforum.com/excel-programming/719027-combine-multiple-workbooks-into-one-single-workbook.html
'Author:     JBeaucaire'
'Date:       9/15/2009     (2007 compatible)'
'Summary:    Open all Excel files in a specific folder and merge data'
'            into one master sheet (stacked)'
'            Moves imported files into another folder'
Dim fName As String, fPath As String, fPathDone As String, OldDir As String
Dim LR As Long, NR As Long
Dim wbkOld As Workbook, wbkNew As Workbook, ws As Worksheet

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Sheets("Sayfa1").Activate   'sheet report is built into...edit to match
    
    If MsgBox("Veriler alınsın mı?", vbYesNo) = vbNo Then Exit Sub
    
    If MsgBox("Eski veriler silinsin mi?", vbYesNo) = vbYes Then
        Range("A2:A" & Rows.Count).EntireRow.ClearContents
        NR = 2
    Else
        NR = Range("A" & Rows.Count).End(xlUp).Row + 1
    End If

'Path and filename
    OldDir = CurDir             'memorizes the user's current working path
    fPath = "F:\Excel Tips\Combine Workbooks\WorkbookData\" 'dosyaların bulunduğu klasör buraya
    fPathDone = "F:\Excel Tips\Combine Workbooks\WorkbookData\Imported\"   'opsiyonel
    ChDir fPath
    fName = Dir("*.xl*")      'filtering key, change to suit

'Import a sheet from found file
    Do While Len(fName) > 0
        'Open file
            Set wbkOld = Workbooks.Open(fName)
        'Find last row and copy data
        '    Sheets(1).Activate
            LR = Range("A" & Rows.Count).End(xlUp).Row
            Range("A3:A" & LR).EntireRow.Copy _
                wbkNew.Sheets("Sayfa1").Range("A" & NR)
        'close file
            wbkOld.Close False
        'Next row
            NR = Range("A" & Rows.Count).End(xlUp).Row + 1
        'move file to "imported" folder
            Name fPath & fName As fPathDone & fName         'opsiyonel
        'ready next filename
            fName = Dir
    Loop

'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

'restores user's original working path
    ChDir OldDir
End Sub

 

[halit3]

Alternatif olarak ekli dosyanızı kontrol ediniz.

not: veri dosyası ve veri alınacak dosyalar aynı yerde olmalı sayfa ismi ve dosya ismi aynı değilse uyarı penceresi açılacaktır burada kendinize ait sayfayı seçmelisiniz.

 

[eewwrree]

Hocam ikinizinde elinize sağlık. mancubus arkadaşın makrosu işime yaradı. Program çalışıyor.

 

[halit3]

Hocam ikinizinde elinize sağlık. mancubus arkadaşın makrosu işime yaradı. Program çalışıyor.

Ben mancubus un kadunu dosya aynı yerdeyken çalıştıramadım çünkü kendisinide açıyor ve veriler yok oluyor kodun ilgili bölümüne

If ThisWorkbook.Name <> fName Then
End If

bunları koymak gerekiyor.

Do While Len(fName) > 0
sonra
If ThisWorkbook.Name <> fName Then

fName = Dir
önce
end if

eklemek gerekiyor