macro to consolidated several workbooks into one master workbook

Hi Experts (excel 2010)
I need a macro to open up all workbook stored in folder “this period” one by one and copy the data in the range A3: AB3, based on the last cell in column A (i.e. dynamically)  find the last value in column A – starting at A4 and then copy the data in the above range from the first workbook and paste the data into the open workbook called “datamart” into worksheet called “change control” data range A3:AB3.
One this has been completed, closed the workbook, from folder “this period”, then
Open up the second workbook, and repeat the above steps, “trick” here is to find where the last data was pasted into the “datamart” worksheet and append the data to the previous copied data from the first workbook. Close workbook once completed
Repeat steps above until all workbook in the folder “this period” have been opened and copied into the master workbook “datamart”
So in a nutshell we are open each workbook one by one stored in folder “this period” and appending the data to the workbook “master”, worksheet “datamart”.
Thanks
route217JuniorAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
 'assume datamart workbook is open and called datamart.xlsm

sub ReadSourceFiles()
'strive4peace, 151115

   On Error GoTo Proc_Err

   dim wbDatamart As Workbook _
      , wsDatamart as worksheet _
      ,wbSource as Workbook 

   dim sFilename as string  _
      ,sPath as string _
      ,nLastRowSource as long _
      ,nRowDatamart as long

   sPath = "c:\folder\this period\ 'put in path to files

   Set wbDatamart = Workbooks("datamart.xlsm")
   wbDatamart.Activate
   Set wsDatamart = wbDatamart.Sheets("change control")
   wsDatamart.Select
   nRowDatamart = 3

   sFilename = dir(sPath & "*.xlsx")

   do while sFilename <> ""

      workbooks.open sPath & sFilename
      set wbSource = activeworkbook

      with activesheet 'assume data is on the first sheet of the opened file since it was not specified
         nLastRowSource = .Cells(4, 1).End(xlDown).Row
         Application.CutCopyMode = False
        .Range("A3:AB" & nLastRowSource).Copy
      End With

      wbDatamart.Activate
      wsDatamart.Cells(nRowDatamart , 1).Select
      ActiveSheet.Paste

      'calculate new next row
      nRowDatamart = nRowDatamart + nLastRowSource - 2

      'close source workbook without saving
      wbSource.Close False
      'get next file
      Dir
   loop

   'save datamart workbook and leave open
   wbDatamart.save

Proc_Exit:
   On Error Resume Next
   'release object variables 
   set wbSource= Nothing
   Set wsDatamart= Nothing
   Set wbDatamart= Nothing
   Exit sub
  
Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   ReadSourceFiles

   Resume Proc_Exit
   Resume
end sub

Open in new window

0
route217JuniorAuthor Commented:
Thanks for the excellent feedback let me test..
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
thank you and you're welcome.  This was aircode so it may need tweaking ~
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

Roy CoxGroup Finance ManagerCommented:
This is some code that I have used successfully for years. It can easily be adapted for your purposes

Option Explicit


'---------------------------------------------------------------------------------------
' Module    : Data
' Author    : Roy Cox (royUK)
' Website   : for more examples and Excel Consulting
' Date      : 19/11/2011
' Purpose   : Combine data from several workbooks
' Disclaimer: Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.
 
'---------------------------------------------------------------------------------------



Sub CombineData()
    Dim oWbk As Workbook
    Dim rRng As Range
    Dim rToCopy As Range
    Dim rNextCl As Range
    Dim lCount As Long
    Dim bHeaders As Boolean
    Dim sFil As String
    Dim sPath As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        '   On Error GoTo exithandler
        ' assumes workbooks are in a sub folder named "Data"
        sPath = ThisWorkbook.Path & Application.PathSeparator & "Data"
        ChDir sPath
        sFil = Dir("*.xl**")    'file type
        Do While sFil <> ""    'will start LOOP until all files in folder sPath have been looped through

            With ThisWorkbook.Worksheets(1)
                Set rRng = .Range("A1").CurrentRegion
                If rRng.Cells.Count = 0 Then
                    'no data in master sheet
                    bHeaders = False
                Else: bHeaders = True
                End If

                Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)    'opens the file
                'A1 must be within the data, if not amend the Range below
                Set rToCopy = oWbk.ActiveSheet.Range("A1").CurrentRegion
                If Not bHeaders Then
                    Set rNextCl = .Cells(1, 1)
                    bHeaders = True
                Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                    'headers exist so don't copy
                    Set rToCopy = rToCopy.Offset(1, 0).Resize(rToCopy.Rows.Count - 1, _
                                                              rToCopy.Columns.Count)
                End If
                rToCopy.Copy rNextCl
            End With
            oWbk.Close False     'close source workbook
            sFil = Dir
        Loop    ' End of LOOP
        'sort to remove empty rows
        Set rRng = ThisWorkbook.Worksheets(1).UsedRange
        rRng.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                  DataOption1:=xlSortNormal
exithandler:
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

Open in new window

0
route217JuniorAuthor Commented:
Roy appreciate the feedback
0
route217JuniorAuthor Commented:
Hi crystal

I am getting g a run time error 424 when run your code. Read source file object required...I have changes the file path...cannot see the error
0
route217JuniorAuthor Commented:
Roy...

I have also tried your method and getting run time error 1004 on line

Set owkb = workbooks.open (spath & application.pathseperator & sFill)
0
route217JuniorAuthor Commented:
Crystal

Fixed that problem. .now have a error 5 readsourcefile invalid procedure call or argument.

And also when macro runs it leave a space of three lines in between copy and paste...can we remove this..
0
Roy CoxGroup Finance ManagerCommented:
That can only be because you haven't set the variables correctly. Have you changed the variable declaration to match your needs. It is currentlt set to work with a subfolder named data withinn the folder that holds the master workbook
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
If you get an error when you run:

press Ctrl-C immediately to copy the error message and paste into a message back to me (that does not always work, in which case you have to type what it says)

Press Ctrl-Break and then choose Debug.  This will take you to the error handler code.  (you may have to OK the message first)

right-click on the statement at the bottom that says Resume
and choose -- Set Next Statement

press F8 to execute a single-step at a time and that will take you back to the line where the error happened (which may or may not be the statement to change)

tell me where you are ~

thanks

______________________

yes, you can remove extra lines.  I put them in to make the code easier to read but there does not need to be 3 ~
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
did you put a \ at the end of the path?

please tell me what you changed this statement to:
sPath = "c:\folder\this period\ 'put in path to files

thank you
0
route217JuniorAuthor Commented:
Crystal

I did put in the \ at the end of the file path..the two errors I get are
1. error 5 readsourcefile invalid procedure call or argument.
2. When the macro runs is copies one of the workbooks from the source destination twice...otherwise nearly prefect.
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
thanks --

1. what statement is the error happening on?  
Ctrl-Break on error, Debug, Set Next Statement to Resume, press F8 to single-step to line that caused problem

2. hmmm ...

add this statement:
debug.print sFilename , Now()

Open in new window

after:
do while sFilename <> ""

press Ctrl-G to turn on the Immediate window, where the debugging stuff will print.  Drag it by its titlebar to be a window instead of docked, and resize it to be taller and not so wide.  When you run, the name of the file it is on will be printed there.

glad it is nearly perfect! Let's get it to the finish line ...
0
Roy CoxGroup Finance ManagerCommented:
The code that I provided has worked for years and contains no unnecessary selecting or activating.. It only needs the path changing

 ' assumes workbooks are in a sub folder named "Data"
        ''///IMPORTANT  This path should be changed for the location of the import files ///
        sPath = ThisWorkbook.Path & Application.PathSeparator & "Data"

Open in new window


If you are not copying to the first sheet in the master workbook then you can change this
 With ThisWorkbook.Worksheets(1)

Open in new window


If you provide the correct path I can edit it for you.

The code below allows the user to browse for the correct folder

Option Explicit

' API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                                     Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
                                                                                       pszpath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
                                   Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
                                   As Long

Public Type BrowseInfo
    hOwner     As Long
    pIDLRoot   As Long
    pszDisplayName As String
    lpszTitle  As String
    ulFlags    As Long
    lpfn       As Long
    lParam     As Long
    iImage     As Long
End Type

Function GetDirectory(Optional msg) As String
    On Error Resume Next
    Dim bInfo  As BrowseInfo
    Dim sPath  As String
    Dim r As Long, x As Long, pos As Integer

    'Root folder = Desktop
    bInfo.pIDLRoot = 0&

    'Title in the dialog
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Please select the folder containing the Excel files to copy."
    Else
        bInfo.lpszTitle = msg
    End If

    'Type of directory to return
    bInfo.ulFlags = &H1

    'Display the dialog
    x = SHBrowseForFolder(bInfo)

    'Parse the result
    sPath = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal sPath)
    If r Then
        pos = InStr(sPath, Chr$(0))
        GetDirectory = Left(sPath, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Sub CombineFiles()
    Dim sPath  As String
    Dim sFileName As String
    Dim rLastCl As Range
    Dim oWb    As Workbook
    Dim oWs    As Worksheet
    Dim oThisWB As String

    On Error GoTo CombineFiles_Error

    oThisWB = ThisWorkbook.Name
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        
        sPath = GetDirectory
        sFileName = Dir(sPath & "\*.xls", vbNormal)
        Do Until sFileName = ""
            If sFileName <> oThisWB Then
                Set oWb = Workbooks.Open(sFileName)
                For Each oWs In oWb.Worksheets
                    Set rLastCl = oWs.Cells.SpecialCells(xlCellTypeLastCell)
                    If rLastCl.Value = "" And rLastCl.Address = Range("$A$1").Address Then
                    Else
                        oWs.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    End If
                Next oWs
                oWb.Close False
            End If
            sFileName = Dir()
        Loop

        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set oWb = Nothing
    Set rLastCl = Nothing
  
    On Error GoTo 0
    Exit Sub

CombineFiles_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") whilst combinining files from " & sPath

Set oWb = Nothing
Set rLastCl = Nothing
End Sub

Open in new window

0
route217JuniorAuthor Commented:
Hi Experts. ..thanks for excellent feedback...

Roy
I got ur code to kind of work..I just need to amend it so it copies data from source files range a5:al and pastes thus into destination workbook range start at a5....
Other than that both vba codes are excellent
0
route217JuniorAuthor Commented:
Roy

Forgot to mention master worksheet has headers in row 4
0
route217JuniorAuthor Commented:
Crystal

Ur code keeps on coping workbook 2 and misses 1 and 3...help
0
route217JuniorAuthor Commented:
Roy

Have read all ur messages and my data sits in a folder called monthly reporting, sepe rate from the master file.....

All worksheets have headers in row 4 I. E. Source and destination files...
0
route217JuniorAuthor Commented:
Sub CombineData()
        Dim oWbk As Workbook
        Dim rRng As Range
        Dim rToCopy As Range
        Dim rNextCl As Range
        Dim lCount As Long
        Dim bHeaders As Boolean
        Dim sFil As String
        Dim sPath As String
   
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
           
'On Error GoTo exithandler
'Assumes workbooks are in a sub folder named "blah"
       
        sPath = "\\blah\blah\blah"
        ChDir sPath
       
        sFil = Dir(sPath & "*.xl**")
        Do While sFil <> ""
            Debug.Print sFil, Now()
           
'Will start LOOP until all files in folder sPath have been looped through

            With ThisWorkbook.Worksheets(1)
                Set rRng = .Range("A5").CurrentRegion
                If rRng.Cells.Count = 0 Then

'No data in master sheet
                    bHeaders = False
                Else: bHeaders = True
                End If
               
'Opens the file
                Set oWbk = Workbooks.Open(sPath & sFil)

'A5 must be within the data, if not amend the Range below
                Set rToCopy = oWbk.ActiveSheet.Range("A5").CurrentRegion
                If Not bHeaders Then
                    Set rNextCl = .cell(5, 1)
                    bHeaders = True
                Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)

'Headers exist so don't copy
                    Set rToCopy = rToCopy.Offset(4, 0).Resize(rToCopy.Rows.Count, _
                                                              rToCopy.Columns.Count)
                End If
                rToCopy.Copy rNextCl
            End With
            oWbk.Close False

'Close source workbook
            sFil = Dir
        Loop
'End of Loop
 
 ActiveWorkbook.Save
       
'Sort to remove empty rows
        Set rRng = ThisWorkbook.Worksheets(1).UsedRange
            'rRng.Sort Key1:=.Range("A5"), Order1:=xlAscending, Header:=xlGuess, _
             '        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
              '        DataOption1:=xlSortNormal
        Range("B5").Select
        ActiveCell.FormulaR1C1 = "1"


Exithandler:
            .ScreenUpdating = True
            .DisplayAlerts = True
            .EnableEvents = True
       
    End With

End Sub
0
route217JuniorAuthor Commented:
Roy...

My version of ur code amended...see previous post
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
> "Ur code keeps on coping workbook 2 and misses 1 and 3."

in that case, it would be best to load the filenames into an array and then loop through the array instead of getting them and processing them in one step.  I'll post back with that code shortly.
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
assuming you have made some changes, I will give you the steps to modify instead of posting the code again.

1. BACKUP YOUR WORKBOOK

Add these DIM statements to the section where variables are being dimensioned:
   Dim arrFile() As String
   Dim iFileNum As Integer

Open in new window

instead of
sFilename = dir(sPath & "*.xlsx")
 add this code to loop through the directory and load all the files into the arrFile array:
   iFileNum = 0
   ReDim arrFile(0)
   arrFile(0) = dir(sPath & "*.xlsx")
   
   Do While arrFile(iFileNum) <> ""
      If (GetAttr(sPath & "\" & arrFile(iFileNum)) _
       And vbDirectory) <> vbDirectory Then
         iFileNum = iFileNum + 1
         ReDim Preserve arrFile(iFileNum)
         arrFile(iFileNum) = Dir()
      End If
   Loop
   
   'remove last entry which is blank
   If iFileNum > 1 Then ReDim Preserve arrFile(iFileNum - 1)

Open in new window

then instead of
do while sFilename <> ""
      workbooks.open sPath & sFilename
use
For iFileNum = LBound(arrFile) To UBound(arrFile)
      workbooks.open sPath & arrFile(iFileNum)

Open in new window

instead of
      'get next file
      Dir
   loop
use
Next iFileNum

Open in new window

Then Debug, Compile, and Save ... and test :)
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
route217JuniorAuthor Commented:
Cheers experts
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
cheers back ~ does it work?
0
Roy CoxGroup Finance ManagerCommented:
Sorry I've not got back but I've been struck by a horrible code. I've read through your amnded code and it looks like it should work.

There is one mistake that I can see

 .cell(5, 1)

Open in new window


Should be

 .cells(5, 1)

Open in new window

0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.