Combine multiple Excel data row wise

[babuthomas23]

Sir,

I have many excel macro workbooks (only one sheet per workbook) in a folder. I want to copy data from each excel's column H and I (till end of data. ie xldown) to column A and B in new summary sheet. The header (row 1) in each excel file is same. So I want to copy data from all excel workbooks 2nd row onwards. The copied data should start from A2 and B2

Regards
Prof. Babu Thomas

[HansV]

Try this macro:

Code: Select all

Sub Merge2Summary()
    Dim strFolder As String
    Dim strFile As String
    Dim wbkSrc As Workbook
    Dim wshSrc As Worksheet
    Dim wbkTrg As Workbook
    Dim wshTrg As Worksheet
    Dim blnFirst As Boolean
    Dim lngSrcRows As Long
    Dim lngTrgRow As Long
    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            strFolder = .SelectedItems(1)
        Else
            MsgBox "You haven't specified a folder!", vbExclamation
            Exit Sub
        End If
    End With
    Set wbkTrg = Workbooks.Add(xlWBATWorksheet)
    Set wshTrg = wbkTrg.Worksheets(1)
    wshTrg.Name = "Summary"
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    blnFirst = True
    strFile = Dir(strFolder & "*.xls*")
    Do While strFile <> ""
        Set wbkSrc = Workbooks.Open(strFolder & strFile)
        Set wshSrc = wbkSrc.Worksheets(1)
        If blnFirst Then
            wshSrc.Rows(1).Copy Target:=wshTrg.Range("A1")
            lngTrgRow = 2
        End If
        lngSrcRows = wshSrc.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        wshSrc.Range("2:" & lngSrcRows).Copy Destination:=wshTrg.Range("A" & lngTrgRow)
        lngTrgRow = lngTrgRow + lngSrcRows - 1
        wbkSrc.Close SaveChanges:=False
        strFile = Dir
    Loop
ExitHandler:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[babuthomas23]

Sir

Thanks. But while opening the folder, it doesnt asks for file type in the pop up window. So no excel files are not shown.

I want to run it for a folder D:/Source

While going through the commands I feel that column H and I alone are copied. I have other cell columns A B C... with some values. I dont need that. I need only H and I coulmn from source file to be copied to summary sheet. All excel files data are to be copied row after other.

Could you please help

Regards
Prof. Babu Thomas

[Rudi]

The code Hans posted does process Excel files, but you are not prompted to select this filter as it is written into the macro.
The line: strFile = Dir(strFolder & "*.xls*") will do this automatically.

When you trigger the macro, it will prompt you to browse for a folder. All files of type: Excel, will be processed in that folder. All you need to do is browse for the folder D:\Source and choose OK. The macro will process the files inside this folder to the Summary sheet.

Here is the reworked code that will process only columns H and I and place the data into the Summary sheet columns A and B.

Code: Select all

Sub Merge2Summary()
    Dim strFolder As String
    Dim strFile As String
    Dim wbkSrc As Workbook
    Dim wshSrc As Worksheet
    Dim wbkTrg As Workbook
    Dim wshTrg As Worksheet
    Dim blnFirst As Boolean
    Dim lngSrcRows As Long
    With Application.FileDialog(4) 'msoFileDialogFolderPicker
        If .Show Then
            strFolder = .SelectedItems(1)
        Else
            MsgBox "You haven't specified a folder!", vbExclamation
            Exit Sub
        End If
    End With
    Set wbkTrg = Workbooks.Add(xlWBATWorksheet)
    Set wshTrg = wbkTrg.Worksheets(1)
    wshTrg.Name = "Summary"
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    blnFirst = True
    strFile = Dir(strFolder & "*.xls*")
    Do While strFile <> ""
        Set wbkSrc = Workbooks.Open(strFolder & strFile)
        Set wshSrc = wbkSrc.Worksheets(1)
        If blnFirst Then
            wshSrc.Range("H1:I1").Copy Destination:=wshTrg.Range("A1")
            blnFirst = False
        End If
        lngSrcRows = wshSrc.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        wshSrc.Range("H2:I" & lngSrcRows).Copy Destination:=wshTrg.Range("A" & Rows.Count).End(xlUp).Offset(1)
        wbkSrc.Close SaveChanges:=False
        strFile = Dir
    Loop
ExitHandler:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[HansV]

Thank you, Rudi.

Babu Thomas: if you only want to use the code for D:\Source, there is no need to prompt for a folder. The following version doesn't display a prompt:

Code: Select all

Sub Merge2Summary()
    Const strFolder = "D:\Source\"
    Dim strFile As String
    Dim wbkSrc As Workbook
    Dim wshSrc As Worksheet
    Dim wbkTrg As Workbook
    Dim wshTrg As Worksheet
    Dim blnFirst As Boolean
    Dim lngSrcRows As Long
    Set wbkTrg = Workbooks.Add(xlWBATWorksheet)
    Set wshTrg = wbkTrg.Worksheets(1)
    wshTrg.Name = "Summary"
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    blnFirst = True
    strFile = Dir(strFolder & "*.xls*")
    Do While strFile <> ""
        Set wbkSrc = Workbooks.Open(strFolder & strFile)
        Set wshSrc = wbkSrc.Worksheets(1)
        If blnFirst Then
            wshSrc.Range("H1:I1").Copy Destination:=wshTrg.Range("A1")
            blnFirst = False
        End If
        lngSrcRows = wshSrc.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        wshSrc.Range("H2:I" & lngSrcRows).Copy Destination:=wshTrg.Range("A" & Rows.Count).End(xlUp).Offset(1)
        wbkSrc.Close SaveChanges:=False
        strFile = Dir
    Loop
ExitHandler:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[babuthomas23]

Thank you Hans and Rudi.

If I want to have consolidation result to be in the same excel where I store the macro, I can change the code like this right!

'Set wbkTrg = Workbooks.Add(xlWBATWorksheet) comment

Set wshTrg = ActiveSheet

'Set wshTrg = wbkTrg.Worksheets(1) comment
'wshTrg.Name = "Summary" comment.


One more question if i want the data in the column A and B sorted based on the value in A, what I should do..

Regards
Prof. Babu Thomas

[Rudi]

Try this:

Code: Select all

Sub Merge2Summary()
    Dim strFolder As String
    Dim strFile As String
    Dim wbkSrc As Workbook
    Dim wshSrc As Worksheet
    Dim wbkTrg As Workbook
    Dim wshTrg As Worksheet
    Dim blnFirst As Boolean
    Dim lngSrcRows As Long
    With Application.FileDialog(4) 'msoFileDialogFolderPicker
        If .Show Then
            strFolder = .SelectedItems(1)
        Else
            MsgBox "You haven't specified a folder!", vbExclamation
            Exit Sub
        End If
    End With
    Set wbkTrg = ThisWorkbook
    Set wshTrg = wbkTrg.Worksheets.Add
    wshTrg.Name = "Summary" '<< Note: Your WB should not have a sheet with this name already!
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    blnFirst = True
    strFile = Dir(strFolder & "*.xls*")
    Do While strFile <> ""
        Set wbkSrc = Workbooks.Open(strFolder & strFile)
        Set wshSrc = wbkSrc.Worksheets(1)
        If blnFirst Then
            wshSrc.Range("H1:I1").Copy Destination:=wshTrg.Range("A1")
            blnFirst = False
        End If
        lngSrcRows = wshSrc.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        wshSrc.Range("H2:I" & lngSrcRows).Copy Destination:=wshTrg.Range("A" & Rows.Count).End(xlUp).Offset(1)
        wbkSrc.Close SaveChanges:=False
        strFile = Dir
    Loop
    wshSrc.Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Key2:=Range("B1"), Header:=xlYes
ExitHandler:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub