4-5 TANE EXCEL Dosyasını Birleştirme ve Güncelleme

[Xandrez]

Merhabalar, öncelikle ekteki dosya gibi bir dosya yapmak istiyorum. Aynı klasörde 4 5 farklı excel var ama aynı formatta. Her kullanıcı kendi exceline veri girdikçe birleştirdiğim dosya güncellenicek. Nasıl birleştiririm ve nasıl güncellenir her açtığımda ?

 

[Xandrez]

Hiç cvp veren yok mu ?

 

[Xandrez]

yok mu cvp ??

 

[Xandrez]

Arkadaşlar acil lazım

 

[Xandrez]

yokmudur yardım edicek olan ??

 

[Xandrez]

Yrdmlarınız için tşk ederim !

 

[gedavet]

http://www.eba.gov.tr/video/izle/02587d6affc27119d4c3fb083b10e1226ff5381ed6027

bu video işinize yararmı

 

[feridici_genc]

dosya birleştirme ile ilgili bir kaç örnek vardı elimde işinizi görür umarım.
her bir kod kendi başına birleştirme işine yarar. modüle kopyalayıp çalıştırın.

******************************************************
hızlı birleştirme ama tek sayfada değil.

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
    Dim Outwbk As Workbook

    Set Outwbk = ActiveWorkbook

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
      MultiSelect:=True, Title:="Files to Merge")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        Sheets().Move After:=Outwbk.Sheets(Outwbk.Sheets.Count)
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Sadece sayfaları taşı/kopyala yaparak birleştiriyor.
her dosyayı ayrı bir sheete getiriyor.

ub CombineWSs()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    MyPath = "C:\Documents and Settings\path\to"
    Set wbDst = ThisWorkbook
    strFilename = Dir(MyPath & "\*.xls", vbNormal)

    If Len(strFilename) = 0 Then Exit Sub

    Do Until strFilename = ""

            Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)

            Set wsSrc = wbSrc.Worksheets(1)

            wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)

            wbSrc.Close False

        strFilename = Dir()

    Loop
    wbDst.Worksheets(1).Delete

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

birden fazla dosyayı tek bir sayfada birleştiriyor.
kullanışlı.

Private Declare Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
    SetCurrentDirectoryA szPath
End Sub

Sub Combine_Workbooks_Select_Files()
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    SaveDriveDir = CurDir
    ChDirNet "C:\" ' birleştirilecek dosyaların adresi

    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    If IsArray(FName) Then
        Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        rnum = 1
        For Fnum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(Fnum))
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("b1:m5000") ' hangi aralıklar birleştirilecek?
                End With
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
        If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Not enough rows in the sheet. "
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        Set destrange = BaseWks.Range("A" & rnum)
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
        Next Fnum
        BaseWks.Columns.AutoFit
    End If
ExitTheSub:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
End Sub