Combine same sheet from multiple workbooks in the same folder

[a1b2c3d4e5f6g7]

Hi,

I have same format workbooks in a folder.

I would like to combine one specific sheet into one workbook. But i have to do this for multiple folders, so is it possible to do this with an vba?

I have a code that combines all OPEN workbooks, but i would like to combine all workbook in this path without opening it.

Sub GetSheets()
Path = "C:\Users\dt\Desktop\dt kte\"
Filename = Dir(Path & "*.xls")
  Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
     For Each Sheet In ActiveWorkbook.Sheets
     Sheet.Copy After:=ThisWorkbook.Sheets(1)
  Next Sheet
     Workbooks(Filename).Close
     Filename = Dir()
  Loop
End Sub

[Pepe Le Mokko]

One of your fellow countrymen has done the job for all of us http://www.rondebruin.nl/win/addins/rdbmerge.htm

[jantonio]

Give this a try:

Dim dic             As Object
Dim Counter         As Long
Sub ConsolidateWorkbooks()
    
    Dim r           As Long
    Dim c           As Long
    Dim n           As Long
    Dim j           As Long
    Dim Fldr        As String
    Dim Fname       As String
    Dim wbkActive   As Workbook
    Dim wbkSource   As Workbook
    Dim Dest        As Range
    Dim d, k()
    
    '// User settings
    Const SourceFileType        As String = "xls*"  'xls,xlsx,xlsb,xlsm
    Const DestinationSheet      As String = "Sheet1"
    Const DestStartCell         As String = "A1"
    Const MaxRows               As Long = 50000
    Const MaxCols               As Long = 100
    Const StartRow              As Long = 2
    '// End
    
    Application.ScreenUpdating = False
    Counter = 0
    With Application.FileDialog(4)
        .Title = "Select source file folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            Fldr = .SelectedItems(1)
        Else
            GoTo Xit
        End If
    End With
    
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    Set wbkActive = ThisWorkbook
    
    ReDim k(1 To MaxRows, 1 To MaxCols)
    
    Set Dest = wbkActive.Worksheets(DestinationSheet).Range(DestStartCell)
    
    Fname = Dir(Fldr & "\*." & SourceFileType)
    
    Do While Len(Fname)
        If wbkActive.Name <> Fname Then
            Set wbkSource = Workbooks.Open(Fldr & "\" & Fname)
            With wbkSource.Worksheets(1)
                d = .Range("a1").CurrentRegion
                UniqueHeaders Application.Index(d, 1, 0)
                For r = StartRow To UBound(d, 1)
                    If Len(d(r, 1)) Then
                        n = n + 1
                        For c = 1 To UBound(d, 2)
                            If Len(Trim$(d(1, c))) Then
                                j = dic.Item(Trim$(d(1, c)))
                                k(n, j) = d(r, c)
                            End If
                        Next
                    End If
                Next
                Erase d
            End With
            wbkSource.Close 0
            Set wbkSource = Nothing
        End If
        Fname = Dir()
    Loop
    
    If n Then
        Dest.Resize(, dic.Count) = dic.keys
        Dest.Offset(1).Resize(n, dic.Count) = k
        MsgBox "Done! Importing Content"
    End If
Xit:
    Application.ScreenUpdating = True
    
End Sub
Private Sub UniqueHeaders(ByRef DataHeader)
    
    Dim i   As Long
    Dim j   As Long
    
    With Application
        j = .ScreenUpdating
        .ScreenUpdating = False
    End With
    
    For i = LBound(DataHeader) To UBound(DataHeader)
        If Len(Trim$(DataHeader(i))) Then
            If Not dic.exists(Trim$(DataHeader(i))) Then
                Counter = Counter + 1
                dic.Add Trim$(DataHeader(i)), Counter
            End If
        End If
    Next
    
    Application.ScreenUpdating = j
    
End Sub