Thursday, 12 June 2014

Merging multiple excel files into one

Sub Macro1()
  Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer

    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from

    ThisWB = ActiveWorkbook.Name
   
    path = "C:\..."

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "\*.xls", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
            Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
            Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Wkb.Close False
        End If
       
        Filename = Dir()
    Loop

    Range("A1").Select
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
   
    MsgBox "Done!"
End Sub

No comments:

Post a Comment