Copying data from multiple sheets of multiple excel.

Hi,
Welcome to the forum,
One Clarification.!
So 28 workbooks with 7 sheets each are to be clubbed in one workbook having seven sheets
so Sheet 1 in all 28 workbooks are to be clubbed one after one in sheet 1 of Resultant workbook.

Hi, BenTenison,

please have a look at WBs to Sheets or Merge data from all workbooks in a folder or RDBMerge, Excel Merge Add-in for Excel for Windows.

HTH,
Holger

Hi Here is the code.
Untested though.
Put all your 28 Files in one Folder in Drive D: Folder Extracts
Open the Main File and run this code on it..

Sub MergeAll()
Application.ScreenUpdating = False
Application.StatusBar = "Please Wait...."

FPath = "D:\Extracts"
MainBook= Thisworkbook.Name
FName = Dir(FPath & "\" & "*.xl*")

Do while FName <> ""
 Workbooks.open (FPath & "\" & FName)
 Workbooks(MainBook).Activate
 For sh = 1 to 7
  Sheets(sh).activate
  c= Cells(rows.count,1).end(xlup).row+1
  if c = 2 then c = 1  
  Workbooks(FName).Sheets(sh).UsedRange.copy Sheets(sh).cells(c,"A")  
 Next
 Workbooks(Fname).Close False
 FName = Dir 
 wb = wb + 1
 Application.StatusBar = "Please Wait.... " & wb & " workbooks done..!   
 DoEvents
Loop

Application.ScreenUpdating = True
Application.StatusBar = ""
Msgbox "Finished" , vbinformation
End Sub

Keep an Eye over Status bar on the left bottom of the screen.
I have tried something with that.

EDIT:- Sorry Ben for that small mistake. I have taken care of that. So now you can try it.
Hi Holger, I do think that third one is a biggi. so I have corrected that.

Thanks for the feedback..
It was totally untested.
Actually I wrote it right here..
I am glad that it worked for you.
Good Luck

Hi, BenTenison,

some weaknesses of the Vikas macro:
- relying on the position of the sheets (not even worksheets) so any change of order will lead to a wrong compilation of data.
- switching of workbooks which is unnessary
- having all workbooks still open at the end of the macro.

I would rather go with the fourth macro from Jerryīs link (the first link I supplied) relying on the sheetnames rather than the index.

Sub MergeAll()
Dim wbThis As Workbook
Dim wbThat As Workbook
Dim FPath As String
Dim FNmae As String
Dim lngSh As Long
Dim lngWB As Long

Application.ScreenUpdating = False
Application.StatusBar = "Please Wait...."

FPath = "D:\Extracts"
Set wbThis = ThisWorkbook
FName = Dir(FPath & "\" & "*.xl*")

Do While FName <> ""
  Set wbThat = Workbooks.Open(FPath & "\" & FName)
  If Not wbThat Is Nothing Then
    For lngSh = 1 To 7
      If wbThat.Sheets(lngSh).Name = wbThis.Sheets(lngSh).Name Then
        wbThat.Sheets(lngSh).UsedRange.Copy wbThis.shetes(lngSh).Cells(Rows.Count, 1).End(xlUp).pffset(1, 0)
      Else
        MsgBox "Sheetname '" & wbThat.Sheets(lngSh).Name & "' doesnīt match position in this workbook"
        GoTo Exit_here
      End If
    Next
    wbThat.Close False
  End If
  
  FName = Dir
  lngWB = lngWB + 1
  Application.StatusBar = "Please Wait.... " & lngWB & " workbooks done..!   "
  DoEvents
Loop

Application.ScreenUpdating = True
Application.StatusBar = ""
MsgBox "Finished", vbInformation
Exit Sub

Exit_here:
Set wbThat = Nothing
Set wbThis = Nothing
Application.StatusBar = ""

End Sub

Ciao,
Holger

Hi, BenTenison,

have a look at PART 4 - Appending Data from All Existing Sheets in all workbooks into a Master Workbook matching the sheetnames. The only thing you might need to add is the addition of a worksheet intoi the masterbook if the names donīt match, I would ask you to clarify on that.

Ciao,
Holger

Have deleted the post & started a new thread

Here is the code you are looking for:-
It is totally untested.

Sub MergeAll()
Application.ScreenUpdating = False
Application.StatusBar = "Please Wait...."

FPath = "D:\Extracts"
MainBook= Thisworkbook.Name
FName = Dir(FPath & "\" & "*.xl*")

Do while FName <> ""
 Workbooks.open (FPath & "\" & FName)
 For Each MainSh in Workbooks(MainBook).Sheets
  lr = MainSh.UsedRange.Rows.count+1
  For Each SubSh in Workbooks(FName).Sheets
   if MainSh.Name = SubSh.Name Then
    SubSh.select
    Set SearchIn = Cells(1,1).CurrentRegion.Rows(1)
    For c = 1 to MainSh.UsedRange.Columns.Count
     ColFnd = application.match(MainSh.cells(1,c),SearchIn,0)
     If not Iserror(ColFnd) then     
      SubSh.Range(cells(2,ColFnd),cells(SubSh.UsedRange.Rows.count, ColFnd)).Copy MainSh.Cells(lr, c)     
     End if
    Next
   End if
  Next
 Next
 Workbooks(Fname).Close False
 FName = Dir 
 wb = wb + 1
 Application.StatusBar = "Please Wait.... " & wb & " workbooks done..!   
 DoEvents
Loop

Application.ScreenUpdating = True
Application.StatusBar = ""
Msgbox "Finished" , vbinformation
End Sub

Edit:- As suggested by Holger.

Hi, Vikas,

this is a public forum and as such any information about some errors should be reported here and not being aslked to be reported via PM.

I think that you respneded to the deleted püost (and the answer should be in the other thread).

Here is the code you are looking for:

You should restraint the loops in both workbooks and leave the loop for the new workbook once a Match was found. Iīd rather had used a Set for the corresponding worksheet in the masterbook (new book delivering the sheetname).

Ciao,
Holger

OK, not problem. It sounded like you got stuck and just started over

Hi Ben Ten,
I have just tested the Code:-
It working perfectly for me without any changes.

Sub MergeAll()
Application.ScreenUpdating = False
Application.StatusBar = "Please Wait...."

FPath = "D:\Extracts"
MainBook= Thisworkbook.Name
FName = Dir(FPath & "\" & "*.xl*")

Do while FName <> ""
 Workbooks.open (FPath & "\" & FName)
 For Each MainSh in Workbooks(MainBook).Sheets
  lr = MainSh.UsedRange.Rows.count+1
  For Each SubSh in Workbooks(FName).Sheets
   if MainSh.Name = SubSh.Name Then
    SubSh.select
    Set SearchIn = Cells(1,1).CurrentRegion.Rows(1)
    For c = 1 to MainSh.UsedRange.Columns.Count
     ColFnd = application.match(MainSh.cells(1,c),SearchIn,0)
     If not Iserror(ColFnd) then     
      SubSh.Range(cells(2,ColFnd),cells(SubSh.UsedRange.Rows.count, ColFnd)).Copy MainSh.Cells(lr, c)     
     End if
    Next
   End if
  Next
 Next
 Workbooks(Fname).Close False
 FName = Dir 
 wb = wb + 1
 Application.StatusBar = "Please Wait.... " & wb & " workbooks done..!   
 DoEvents
Loop

Application.ScreenUpdating = True
Application.StatusBar = ""
Msgbox "Finished" , vbinformation
End Sub

1. The possible reason for the failure can be that the column headers in the MainBook is not matching exactly with headers in the Sub sheets.
If I comes out to be correct, then we will proceed to correct it as well.

I have made some changes...
and its working now..

Sub MergeAll()
Dim MainSh As Worksheet
Dim SubSh As Worksheet
Dim SearchIn As Range
'Clearing Previous data
For Each sh In ThisWorkbook.Sheets
    sh.Cells(1, 0).CurrentRegion.Offset(1, 1).Clear
Next

Application.ScreenUpdating = False
Application.StatusBar = "Please Wait...."

FPath = "C:\Documents and Settings\Administrator\Desktop\Vikas Gautam xlfiles\Extracts\Extracts"
MainBook = ThisWorkbook.Name
FName = Dir(FPath & "\" & "*.xl*")

Do While FName <> ""
 Workbooks.Open (FPath & "\" & FName)
 For Each MainSh In Workbooks(MainBook).Sheets
  temp = MainSh.Name
  lr = MainSh.Cells(1, 1).CurrentRegion.Rows.Count + 1
  For Each SubSh In Workbooks(FName).Sheets
   If MainSh.Name = SubSh.Name And SubSh.Name <> "Summary" Then
    SubSh.Select
    Set SearchIn = Cells(1, 1).CurrentRegion.Rows(1).Offset(0, 1)
    SearchIn.Select
    For c = 2 To MainSh.UsedRange.Columns.Count
     ColFnd = Application.Match(MainSh.Cells(1, c), SearchIn, 0) + 1
     If Not IsError(ColFnd) Then
      SubSh.Range(Cells(2, ColFnd), Cells(SubSh.UsedRange.Rows.Count, ColFnd)).Copy MainSh.Cells(lr, c)
     End If
    Next
   End If
  Next
 Next
 Workbooks(FName).Close False
 FName = Dir
 wb = wb + 1
 Application.StatusBar = "Please Wait.... " & wb & " workbooks done..!   "
 DoEvents
Loop

Application.ScreenUpdating = True
Application.StatusBar = ""
MsgBox "Finished", vbInformation
End Sub

I am sorry Ben,
It was my mistake..
Its working now..

Sub MergeAll()
Dim MainSh As Worksheet
Dim SubSh As Worksheet
Dim SearchIn As Range

'Clearing Previous data
For Each Sh In ThisWorkbook.Sheets
    Sh.Cells(1, 1).CurrentRegion.Offset(1, 0).Clear
Next

Application.ScreenUpdating = False
Application.StatusBar = "Please Wait...."

FPath = "C:\Users\Vikas Gautam\Desktop\Extracts\Extracts"
MainBook = ThisWorkbook.Name
FName = Dir(FPath & "\" & "*.xl*")

Do While FName <> ""
 Workbooks.Open (FPath & "\" & FName)
 For Each MainSh In Workbooks(MainBook).Sheets
  temp = MainSh.Name
  lr = MainSh.Cells(1, 1).CurrentRegion.Rows.Count + 1
  For Each SubSh In Workbooks(FName).Sheets
   If MainSh.Name = SubSh.Name And SubSh.Name <> "Summary" Then
    Set SearchIn = Cells(1, 1).CurrentRegion.Rows(1).Offset(0, 1)
    For c = 2 To MainSh.UsedRange.Columns.Count
     ColFnd = Application.Match(MainSh.Cells(1, c), SearchIn, 0) + 1
     If Not IsError(ColFnd) Then
      SubSh.Range(Cells(2, ColFnd), Cells(SubSh.UsedRange.Rows.Count, ColFnd)).Copy MainSh.Cells(lr, c)
     End If
    Next
   End If
  Next
 Next
 Workbooks(FName).Close False
 FName = Dir
 wb = wb + 1
 Application.StatusBar = "Please Wait.... " & wb & " workbooks done..!   "
 DoEvents
Loop

Application.ScreenUpdating = True
Application.StatusBar = ""
MsgBox "Finished", vbInformation
End Sub

There is a MainBook.xlsm file in Mainbook folder in the attachment.
Check the attached zip attachment

Have you changed the Folder Path...?
you have to change it with your actual path..

Edit:- I have Completely rebuild the Code. You can give it a try if you want.

Sub MergeAll()
'Declaring Variables
Dim MainSh As Worksheet
Dim SubSh As Worksheet
Dim SearchIn As Range

Application.ScreenUpdating = False
Application.StatusBar = "Please Wait...."
                                            
FPath = "C:\Users\Vikas Gautam\Desktop\Extracts\Extracts\Extracts"    '<--Change the file path for extracts
MainBook = ThisWorkbook.Name
FName = Dir(FPath & "\" & "*.xl*")
                                            
'Clearing Previous Contents in the MainBook
For Each Sh In ThisWorkbook.Sheets
    Sh.Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
Next
                                            
Do While FName <> ""
 Workbooks.Open (FPath & "\" & FName)                     '<--Opening Extract Workbook
 For Each MainSh In Workbooks(MainBook).Sheets            '<--Taking MainBook as Base
  Lr = MainSh.Cells(1, 1).CurrentRegion.Rows.Count + 1    '<--Marking the Last row where data is to be pasted in the Sheet in MainBook
  For Each SubSh In Workbooks(FName).Sheets
   If MainSh.Name = SubSh.Name Then                 '<--Checking if Sheet Name matches with that of MainBook
    Set SearchIn = SubSh.Rows(1)                    '<--Marking First Row in SubSh to be searched for getting corresponding Col.
    For c = 1 To MainSh.Cells(1, Columns.Count).End(xlToLeft).Column
     ColFnd = Application.Match(MainSh.Cells(1, c), SearchIn, 0) '<--Marking Col No. by matching Col Heads in SubSh with that of MainBook
     If Not IsError(ColFnd) Then
      SubSh.Range(Cells(2, ColFnd).Address, SubSh.Cells(Rows.Count, ColFnd).End(xlUp).Address).Copy _
      MainSh.Cells(Lr, c)                                         '<--Copying and pasting data in MainBook
     End If
    Next
   End If
  Next
 Next

 Workbooks(FName).Close False            '<--Closing Extract sheet without saving it
 FName = Dir                             '<--Moving onto next Extract Sheet
 wb = wb + 1                             '<--Adding 1 to Extract workbook Counter
 Application.StatusBar = "Please Wait.... " & wb & " workbooks done..!"
 DoEvents                                '<--Updating the status bar
Loop
                                            
Application.ScreenUpdating = True
Application.StatusBar = ""
MsgBox "Finished", vbInformation
End Sub