CODEWITHSUNDEEP
vbaexcelmerge
Anubhav Dikshit
Anubhav Dikshit

Reputation: 1829

Merge multiple .xls files into one sheet

I have a folder full of .xls files, all the files have the same structure (column names), I wanted the code to open each file in the folder and copy the contents of sheet1 and paste in another excel file into sheet1, open the second file copy and append in sheet 1.

Currently the code I have does this as different sheet

  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

Upvotes: 1

Views: 8940

Answers (1)

R3uK
R3uK

Reputation: 14547

This should do the trick :

Sub GetSheets()
Dim WriteRow As Long, _
    LastCell As Range, _
    WbDest As Workbook, _
    WbSrc As Workbook, _
    WsDest As Worksheet, _
    WsSrc As Worksheet

Set WbDest = ThisWorkbook
Set WsDest = WbDest.Sheets.Add
WsDest.Cells(1, 1) = "Set your headers here"

Path = "C:\Users\dt\Desktop\dt kte\"
Filename = Dir(Path & "*.xls")

Do While Filename <> ""
    Set WbSrc = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
    Set WsSrc = WbSrc.Sheets(1)
    With WsSrc
        Set LastCell = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False)
        .Range(.Range("A1"), LastCell).Copy
    End With
    With WsDest
        WriteRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row + 1
        '.Range("A" & WriteRow).Paste
        'OR
        .Range("A" & WriteRow).PasteSpecial
    End With
    '''To clear clipboard to avoid 'large clipboard' warnings on close
    Application.CutCopyMode = False

    WbSrc.Close
    Filename = Dir()
Loop

End Sub

Upvotes: 3

Related Questions