Merge from multiple files into new workbook in Excel 2007?

[rdhaan]

Hi,

I had the following code working in Excel 2003 to read a hidden tab (SummaryMirror) with data and copy the data into one new workbook for all files within a specific directory.

Sub MergeTrackers()
Dim lastRow As Integer
Dim docPath As String
Dim baseCell As Excel.Range
Dim sysObj As Variant, folderObj As Variant, fileObj As Variant
Application.ScreenUpdating = False
docPath = Application.GetOpenFilename(FileFilter:="Text Files (*.txt),*.txt,Excel Files (*.xls),*.xls,Excel 2007 Files (*.xlsx),*.xlsx", FilterIndex:=2, Title:="Choose any file")
Workbooks.Add
Set baseCell = Range("A1")
Set sysObj = CreateObject("scripting.filesystemobject")
Set fileObj = sysObj.getFile(docPath)
Set folderObj = fileObj.ParentFolder
Application.DisplayAlerts = False
For Each fileObj In folderObj.Files
Workbooks.Open Filename:=fileObj.Path
Sheets("SummaryMirror").Visible = True
Sheets("SummaryMirror").Unprotect Password:="password"
Sheets("SummaryMirror").Select
Range(Range("A1:N12"), ActiveCell.SpecialCells(xlLastCell)).Copy
lastRow = baseCell.SpecialCells(xlLastCell).Row
baseCell.Offset(lastRow, 0).PasteSpecial (xlPasteValues)
baseCell.Copy
ActiveWindow.Close SaveChanges:=False
Next
End Sub

I upgraded to Excel 2007 and now the code does not work anymore... Does anyone know how to solve for Excel 2007?

Many thanks!

 

[SkipVought]

Hi,

See if this works for you...

Sub MergeTrackers()
    
    Dim docPath As String
    Dim baseCell As Excel.Range
    Dim sysObj As Variant, folderObj As Variant, fileObj As Variant
    Application.ScreenUpdating = False
    docPath = Application.GetOpenFilename(FileFilter:="Text Files (*.txt),*.txt,Excel Files (*.xls),*.xls,Excel 2007 Files (*.xlsx),*.xlsx", FilterIndex:=2, Title:="Choose any file")
    Workbooks.Add
    Set baseCell = ActiveSheet.Range("A1")
    Set sysObj = CreateObject("scripting.filesystemobject")
    Set fileObj = sysObj.getFile(docPath)
    Set folderObj = fileObj.ParentFolder
    Application.DisplayAlerts = False
    For Each fileObj In folderObj.Files
        With Workbooks.Open(Filename:=fileObj.Path)
        
            .Sheets("SummaryMirror").Visible = True
            .Sheets("SummaryMirror").Unprotect Password:="password"
            .Sheets("SummaryMirror").Select
            
            .[A1].CurrentRegion.Copy
            baseCell.PasteSpecial (xlPasteValues)
            Set baseCell = baseCell.End(xlDown).Offset(1)
            
            .Close SaveChanges:=False
        End With
    Next
End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[rdhaan]

Hello Skip,

Many thanks for your quick response.
Unfortunately, it does not work.

It breaks on the Workbooks.Add line.
However, I can press continue and it then creates a new file correctly.

It then breaks again on the .Sheets("SummaryMirror").Visible = True line.

I can press continue again, and then it breaks on .[A1].CurrentRegion.Copy
Error message: Run-time error '438'. Object doesn't support this property or method.
Now I cannot continue.

Regards,

Remco

 

[SkipVought]

What SHEET is it on when it errors on

.[A1].CurrentRegion.Copy

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[rdhaan]

Skip,

Thanks for replying again! Much appreciated.

If you mean which sheet is visible on the screen, than it is the source file sheet - the summary mirror. This sheet contains the range (A1:N12) which I want to copy.

Hope you can help.

Bye,
Remco

 

[SkipVought]

Is that range, the extent of the data on that sheet that is CONTIGUOUS to A1? I assumed that it was. If not, the RANGE must be changed...

    For Each fileObj In folderObj.Files
        With Workbooks.Open(Filename:=fileObj.Path)
        
            .Sheets("SummaryMirror").Visible = True
            .Sheets("SummaryMirror").Unprotect Password:="password"
            .Sheets("SummaryMirror").Select
            [b]
            .Sheets("SummaryMirror").[A1].CurrentRegion.Copy[/b]
            baseCell.PasteSpecial (xlPasteValues)
            Set baseCell = baseCell.End(xlDown).Offset(1)
            
            .Close SaveChanges:=False
        End With
    Next

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[rdhaan]

Hello Skip,

I tried that correction and the copying now works.

However, it still breaks on the Workbooks.Add line (but only once). I can press continue.

It then breaks again on the .Sheets("SummaryMirror").Visible = True line.
I can press continue.

And on the 'baseCell.PasteSpecial (xlPasteValues)' line.
I can press continue.

And finally it breaks on the 'End With' statement (before it continues to the next file).

So by clicking a minimum of 3 times continue per processed file it works, which is doable (ca 40 files to process). But it would of course be great if it wouldn't break at all.

The code now looks like this (which should be similar to your specification).

Sub MergeTrackers()

Dim docPath As String
Dim baseCell As Excel.Range
Dim sysObj As Variant, folderObj As Variant, fileObj As Variant
Application.ScreenUpdating = False
docPath = Application.GetOpenFilename(FileFilter:="Text Files (*.txt),*.txt,Excel Files (*.xls),*.xls,Excel 2007 Files (*.xlsx),*.xlsx", FilterIndex:=2, Title:="Choose any file")
Workbooks.Add
Set baseCell = ActiveSheet.Range("A1")
Set sysObj = CreateObject("scripting.filesystemobject")
Set fileObj = sysObj.getFile(docPath)
Set folderObj = fileObj.ParentFolder
Application.DisplayAlerts = False
For Each fileObj In folderObj.Files
With Workbooks.Open(Filename:=fileObj.Path)

.Sheets("SummaryMirror").Visible = True
.Sheets("SummaryMirror").Unprotect Password:="password"
.Sheets("SummaryMirror").Select
.Sheets("SummaryMirror").[A1].CurrentRegion.Copy
baseCell.PasteSpecial (xlPasteValues)
Set baseCell = baseCell.End(xlDown).Offset(1)

.Close SaveChanges:=False
End With
Next

End Sub

Hope you can help me solve this?

Remco

 

[SkipVought]

I have not idea why the BREAK occurs.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[rdhaan]

Hey Skip,

Thanks anyway for your help so far...

Could it be some (security) setting in Excel that causes the code to break?

Remco