You are here:

Excel/VBA Macro - Copy data from separate workbooks into master workbook

Advertisement


Question
QUESTION: I have about 30 workbooks that track service charge pay for our employees. Each workbook has two separate summary sheets that I would like to consolidate (there are more than just these two sheets in each workbook). The worksheets are named "Master Service Charge" and "Master Upload."

I need a macro that will copy the "Master Upload" sheet from all workbooks into one master workbook. The Master Upload has the same header row on each sheet and the master sheet needs to have the same header. Then the data from each sheet needs to be placed one after another, so it creates our payroll upload file. The Macro needs to automatically find the last column and last row on each sheet, since the amount of data in each workbook varies. I would like it to open a dialog box that asks which excel files to open. The macro also needs to copy and paste values, I do not want formulas being copied.

I would like the macro to be setup so I can easy change the worksheet it pulls from workbook. I need it to do the same thing with "Master Service Charge." I plan on having separate master files for each the Master Service Charge and Master Upload. I need to be able to change how many rows are in the header between the two.

If you could supply me with any advise I would greatly appreciate. I am hoping to find a generic code that I can modify for the uses I need. Thanks!!!

ANSWER: Michael,

Obviously it would be difficult to find generic code that is going to run right out of the box and do everything you describe.  

Nonetheless, much of what you describe is fairly generic and you can find code the will give you a running start.

Ron de Bruin had several pages related to your request.  

http://www.rondebruin.nl/windows_articles.htm

is a list of his article.  If you look toward the bottom he has two links:

- Consolidating Data from Multiple Worksheets into a Summary Worksheet in Excel

- Merging Data from Multiple Workbooks into a Summary Workbook in Excel

He also has a link to an MSDN article he wrote related to this topic

-----------------------------
Office Visual How To

Merging Data from Multiple Workbooks into a Summary Workbook in Excel
which has the link:
http://msdn.microsoft.com/en-us/library/gg549168.aspx
----------------------------

So those should show you the basics. If you have a specific question you can always post back to me in allexperts.

Hopefully this is what you wanted as that is the way I understood your question.

--
Regards,
Tom Ogilvy


---------- FOLLOW-UP ----------

QUESTION: Thanks for your help Tom,

I cannot figure out how to copy my header row. It is the same on all worksheets. Here is my code. I think I have it expect for the header row.

Dim FirstCell As String

#If VBA7 Then
   Declare PtrSafe Function SetCurrentDirectoryA Lib _
   "kernel32" (ByVal lpPathName As String) As Long
#Else
   Declare Function SetCurrentDirectoryA Lib _
   "kernel32" (ByVal lpPathName As String) As Long
#End If

Sub ChDirNet(szPath As String)
   SetCurrentDirectoryA szPath
End Sub

Sub MergeAllWorkbooks()
   Dim MyPath As String
   Dim SourceRcount As Long, Fnum As Long
   Dim mybook As Workbook, BaseWks As Worksheet
   Dim sourceRange As Range, destrange As Range
   Dim rnum As Long, CalcMode As Long
   Dim SaveDriveDir As String
   Dim FName As Variant


   'Change ScreenUpdating, Calculation and EnableEvents
   With Application
       CalcMode = .Calculation
       .Calculation = xlCalculationManual
       .ScreenUpdating = False
       .EnableEvents = False
   End With

   SaveDriveDir = CurDir
   ChDirNet "C:\Users\Ron\test"

   FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
         MultiSelect:=True)
   If IsArray(FName) Then

       'Add a new workbook with one sheet
       Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
       rnum = 1

       'Loop through all files in the array(myFiles)
       For Fnum = LBound(FName) To UBound(FName)
         Set mybook = Nothing
         On Error Resume Next
         Set mybook = Workbooks.Open(FName(Fnum))
         On Error GoTo 0

         If Not mybook Is Nothing Then

         On Error Resume Next
         With mybook.Worksheets("Summary")
         FirstCell = "A2"
         Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
         'Test if the row of the last cell >= then the row of the FirstCell
         If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
         Set sourceRange = Nothing
         End If
         End With

         If Err.Number > 0 Then
         Err.Clear
         Set sourceRange = Nothing
         Else
         'if SourceRange use all columns then skip this file
         If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
         Set sourceRange = Nothing
         End If
         End If
         On Error GoTo 0

         If Not sourceRange Is Nothing Then

         SourceRcount = sourceRange.Rows.Count

         If rnum + SourceRcount >= BaseWks.Rows.Count Then
         MsgBox "Sorry there are not enough rows in the sheet"
         BaseWks.Columns.AutoFit
         mybook.Close savechanges:=False
         GoTo ExitTheSub
         Else
         'Set the destrange
         Set destrange = BaseWks.Range("A" & rnum)

         'we copy the values from the sourceRange to the destrange
         With sourceRange
         Set destrange = destrange. _
         Resize(.Rows.Count, .Columns.Count)
         End With
         destrange.Value = sourceRange.Value

         rnum = rnum + SourceRcount
         End If
         End If
         mybook.Close savechanges:=False
         End If

       Next Fnum
       BaseWks.Columns.AutoFit
   End If

ExitTheSub:
   'Restore ScreenUpdating, Calculation and EnableEvents
   With Application
       .ScreenUpdating = True
       .EnableEvents = True
       .Calculation = CalcMode
   End With
   ChDirNet SaveDriveDir
End Sub

Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
   Dim lrw As Long
   Dim lcol As Integer

   Select Case choice

   Case 1:
       On Error Resume Next
       RDB_Last = rng.Find(What:="*", _
         after:=rng.Cells(1), _
         Lookat:=xlPart, _
         LookIn:=xlFormulas, _
         SearchOrder:=xlByRows, _
         SearchDirection:=xlPrevious, _
         MatchCase:=False).Row
       On Error GoTo 0

   Case 2:
       On Error Resume Next
       RDB_Last = rng.Find(What:="*", _
         after:=rng.Cells(1), _
         Lookat:=xlPart, _
         LookIn:=xlFormulas, _
         SearchOrder:=xlByColumns, _
         SearchDirection:=xlPrevious, _
         MatchCase:=False).Column
       On Error GoTo 0

   Case 3:
       On Error Resume Next
       lrw = rng.Find(What:="*", _
         after:=rng.Cells(1), _
         Lookat:=xlPart, _
         LookIn:=xlFormulas, _
         SearchOrder:=xlByRows, _
         SearchDirection:=xlPrevious, _
         MatchCase:=False).Row
       On Error GoTo 0

       On Error Resume Next
       lcol = rng.Find(What:="*", _
         after:=rng.Cells(1), _
         Lookat:=xlPart, _
         LookIn:=xlFormulas, _
         SearchOrder:=xlByColumns, _
         SearchDirection:=xlPrevious, _
         MatchCase:=False).Column
       On Error GoTo 0

       On Error Resume Next
       RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
       If Err.Number > 0 Then
         RDB_Last = rng.Cells(1).Address(False, False)
         Err.Clear
       End If
       On Error GoTo 0

   End Select
End Function

Answer
Michael,


Dim bHeader as Boolean
bHeader = False
If IsArray(FName) Then

       'Add a new workbook with one sheet
       Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
   '    rnum = 1
       'Start to copy to row 2  
        rnum = 2
       'Loop through all files in the array(myFiles)
       For Fnum = LBound(FName) To UBound(FName)
         Set mybook = Nothing
         On Error Resume Next
         Set mybook = Workbooks.Open(FName(Fnum))
         On Error GoTo 0

         If Not mybook Is Nothing Then
         if not bHeader then
         ' copy header one time and mark as done
         myBook.Worksheets("Summary").Rows(1).copy BaseWks.Rows(1)
         ' mark that header has been copied
         bHeader = True
         end if
   . . .

--
Regards,
Tom Ogilvy

About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Tom Ogilvy

Expertise

Selected as an Excel MVP by Microsoft since 1999. Answering Excel questions in Allexperts since its inception in 2001. Able to answer questions on almost all aspects of Excel's internal capabilities. If seeking a VBA solution, please specify that in your question itself so I give you the answer you want. [Excel has weak protection - if you are distributing an application, I don't answer questions on how to protect your project from your users.]

Experience

Extensive experience.

Education/Credentials
Master of Science (MS) degree Operations Research (ORSA)

Awards and Honors
Microsoft MVP in Excel.

©2016 About.com. All rights reserved.