Help on merging multiple excel files data

[Closed]
Report
Posts
28
Registration date
Wednesday January 27, 2010
Status
Member
Last seen
May 27, 2013
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
Hello,

I am trying to merge multiple excel files placed in a folder. all of them have same headers and similar pattern of data. the purpose of the same is to collect that data from all excel work books and compile in single workbook and sheet. pls help me getting it done. i don't know whether any command is need to be used or it would be done by some macro.. i am using MS Office 2007.

your help in this regard is much appreciated.

Thanks...may

4 replies

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
You would need a macro for that
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Posts
28
Registration date
Wednesday January 27, 2010
Status
Member
Last seen
May 27, 2013
5
how would it be if following are excel file names and headers to be used for this merge process.

Excel file name: abc1, abc2, abc3
(all contains data in sheet1)

data headers (columns): a, b, c, d, e, f, g, h, i, j, k, L

data exist in different number of rows randomly. few files contains data from row2 to row10 and some may contain data from row2 to row90.

need your support to create a sample macro for it.
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Try this
Option Explicit

Sub consolidateIntoOneBook()

Dim sourceFolder        As String
Dim sourceFile          As String
Dim sourceBook          As Workbook
Dim sourceSheet         As String
Dim sourceRows          As Long
Dim sourceCols          As Long
Dim TargetBook          As Workbook

Dim targetSheet         As String
Dim targetRows          As Long
Dim maxPossibleRows     As Long
Dim startRow            As Integer
   
   sourceSheet = "Sheet1"
   targetSheet = "Consolidated"
   
   sourceFolder = InputBox("Enter the full path where files exists", "Excel Files Path")
   sourceFolder = Trim(sourceFolder)
   If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
   sourceFile = Dir(sourceFolder & "*.xls*")
   If (sourceFile = vbNullString) Then
      MsgBox "No *.xls* files found at location [" & sourceFile & "]", vbInformation, "Error"
      GoTo consolidateIntoOneBook_Exit
   End If
   
   On Error GoTo consolidateIntoOneBook_Err
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   Set TargetBook = Workbooks.Add
   TargetBook.Sheets("Sheet1").Name = targetSheet
   maxPossibleRows = TargetBook.Sheets(targetSheet).Rows.Count
   startRow = 1
   targetRows = 0
   Do Until sourceFile = vbNullString
      Set sourceBook = Workbooks.Open(Filename:=sourceFolder & sourceFile)
      
      With sourceBook.Sheets(sourceSheet)
         sourceRows = getItemLocation("*", .Cells)
         sourceCols = getItemLocation("*", .Cells, bFindRow:=False)
         If (targetRows + (sourceRows - startRow) + 1 > maxPossibleRows) Then
            MsgBox "Copying data from workbook [" & sourceFile & "] will exceed excel imposed limitation of " & maxPossibleRows & " rows."
            GoTo consolidateIntoOneBook_Exit
         End If
         
         Application.CutCopyMode = False
         .Range(.Cells(startRow, 1), .Cells(sourceRows, sourceCols)).Copy
         TargetBook.Sheets(targetSheet).Cells(targetRows + 1, 1).PasteSpecial
         targetRows = targetRows + sourceRows - startRow + 1
         Application.CutCopyMode = False
         startRow = 2
      End With
      sourceBook.Close False
      sourceFile = Dir()
   Loop

consolidateIntoOneBook_Exit:
    Application.EnableEvents = True
    Application.ScreenUpdating = True

   Exit Sub
   
consolidateIntoOneBook_Err:
   MsgBox "Error Occured while processing request. " & Err.Description, vbCritical, "Critical Error"
   GoTo consolidateIntoOneBook_Exit
   
End Sub
   
Public Function getItemLocation(sLookFor As String, _
                                rngSearch As Range, _
                                Optional bFullString As Boolean = True, _
                                Optional bLastOccurance As Boolean = True, _
                                Optional bFindRow As Boolean = True) As Long
                                   
   'find the first/last row/column  within a range for a specific string
      
   Dim Cell             As Range
   Dim iLookAt          As Integer
   Dim iSearchDir       As Integer
   Dim iSearchOdr       As Integer
         
   If (bFullString) _
   Then
      iLookAt = xlWhole
   Else
      iLookAt = xlPart
   End If
   If (bLastOccurance) _
   Then
      iSearchDir = xlPrevious
   Else
      iSearchDir = xlNext
   End If
   If Not (bFindRow) _
   Then
      iSearchOdr = xlByColumns
   Else
      iSearchOdr = xlByRows
   End If
         
   With rngSearch
      If (bLastOccurance) _
      Then
         Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
      Else
         Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
      End If
   End With
         
   If Cell Is Nothing Then
      getItemLocation = 0
   ElseIf Not (bFindRow) _
   Then
      getItemLocation = Cell.Column
   Else
      getItemLocation = Cell.Row
   End If
   Set Cell = Nothing

End Function
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Can a mod. restore the msg that seems to be a victim of sanitization
Posts
28
Registration date
Wednesday January 27, 2010
Status
Member
Last seen
May 27, 2013
5
thanks @rizvisa1. can you pls report the message.
Posts
28
Registration date
Wednesday January 27, 2010
Status
Member
Last seen
May 27, 2013
5
sorry its repost message.
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
thanks Ambucias for restoring the msg