You are here:

Excel/Rollup across separate workbooks

Advertisement


Question
QUESTION: Hi,

You had previously assisted me with a macro to rollup data from specific worksheets within a single workbook. That code is below. It works great (thanks again), but I have had a request recently to separately have an option to do a similar rollup but from separate workbooks. So within a folder we would have a Rollup Workbook and then other workbooks as well that have the data.  Macro in rollup workbook would open those data files look for worksheets with specific name, then if found copy data (as in original macro) out and into rollup workbook.  Files will either live in a folder on a file share or possibly in a folder within a document library on a SharePoint site.  Could you provide me with some direction and/or assist directly with new code?

Current macro is below (when all lives in one workbook)

Sub Combine()
Application.DisplayAlerts = False
Worksheets("Rollup").Range("A2:U65536").Clear
   Dim i   As Long
   For i = 1 To Worksheets.Count
       With Sheets(i)
         .AutoFilterMode = False
    End With
Next
Dim ws As Worksheet, Rws As Long
' copy headings
With Sheets(3)
   .Range("A5:U5").Copy Destination:=Sheets(2).Range("A2")
End With
' work through sheets
For Each ws In Worksheets
If ws.Name Like "*ComResp*" Then
   With ws.Range("A6").CurrentRegion
       Rws = .Rows.Count
       .Offset(2, 0).Resize(Rws - 1).Copy
   End With
   With Sheets(2).Range("A65536").End(xlUp)(2)
       .PasteSpecial Paste:=xlPasteValues
       .PasteSpecial Paste:=xlPasteFormats
       Application.CutCopyMode = False
   End With
End If
Next ws
Sheets(2).Activate
End Sub

ANSWER: Have a look whether this fits your needs:

Option Explicit

Sub GetOpenFileNameExample3()
   Dim lCount As Long
   Dim vFilename As Variant
   Dim sPath As String
   Dim lFilecount As Long
   sPath = "c:\windows\temp\" 'Change as needed
   ChDrive sPath
   ChDir sPath
   vFilename = Application.GetOpenFilename("Microsoft Excel files (*.xls),*.xls", , "Please select the file(s) to open", , True)
   If TypeName(vFilename) = "Boolean" Then Exit Sub
   For lCount = LBound(vFilename) To UBound(vFilename)
       Combine CStr(vFilename(lCount))
   Next
End Sub


Sub Combine(sFilename As String)
   Dim ws As Worksheet
   Dim Rws As Long
   Dim oBk As Workbook
   Workbooks.Open sFilename
   Set oBk = ActiveWorkbook
   Application.DisplayAlerts = False
   ThisWorkbook.Worksheets("Rollup").Range("A2:U65536").Clear
   Dim i As Long
   For i = 1 To oBk.Worksheets.Count
       With oBk.Sheets(i)
         .AutoFilterMode = False
       End With
   Next
   ' copy headings
   With Sheets(3)
       .Range("A5:U5").Copy Destination:=Sheets(2).Range("A2")
   End With
   ' work through sheets
   For Each ws In oBk.Worksheets
       If ws.Name Like "*ComResp*" Then
         With ws.Range("A6").CurrentRegion
         Rws = .Rows.Count
         .Offset(2, 0).Resize(Rws - 1).Copy
         End With
         With ThisWorkbook.Sheets(2).Range("A65536").End(xlUp)(2)
         .PasteSpecial Paste:=xlPasteValues
         .PasteSpecial Paste:=xlPasteFormats
         Application.CutCopyMode = False
         End With
       End If
   Next ws
   ThisWorkbook.Sheets(2).Activate
   oBk.Close False
End Sub


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

QUESTION: Looks good but a few comments or things to change if possible.

1. I would prefer that the macro just opens all other xlsm files in the same folder that the rollup file lives in and pulls that data out per macro criteria vs. specifying which ones to open. Or user could select a folder where files live, but would prefer not to have to select each file individually.
2. I would like to remove this action such that first 2 rows in rollup will just remain fixed.
' copy headings
  With Sheets(3)
      .Range("A5:U5").Copy Destination:=Sheets(2).Range("A2")
  End With

3. I think this action needs to be moved earlier because I think currently each time it opens a file its going to erase that range such that its then not appending (rolling up) the data, itís just deleting content each time and adding data from current file. This works with original macro scenario where all was happening in one workbook but I think with different workbooks it needs to be adjusted.

ThisWorkbook.Worksheets("Rollup").Range("A3:U65536").Clear

FYI: Range above had been ("A2:U65536") but I think now needs to be ("A3:U65536") because of item 2 above.

Thanks again for your help.

Mark

ANSWER: Hi Mark,

This should come close (untested).

Option Explicit

Sub GetOpenFileNameExample3()
   Dim lCount As Long
   Dim sFilename As String
   Dim sPath As String
   Dim lFilecount As Long
   sPath = ThisWorkbook.Path & "\"
   ChDrive sPath
   ChDir sPath
   ' copy headings
   With Sheets(3)
       .Range("A5:U5").Copy Destination:=Sheets(2).Range("A2")
   End With
   ThisWorkbook.Worksheets("Rollup").Range("A3:U65536").Clear
   sFilename = Dir(sPath & "*.xlsm")
   Do
       If sFilename <> ThisWorkbook.Name Then
         Combine sFilename
       End If
       sFilename = Dir()
   Loop Until Len(sFilename) = 0
End Sub


Sub Combine(sFilename As String)
   Dim ws As Worksheet
   Dim Rws As Long
   Dim oBk As Workbook
   Workbooks.Open sFilename
   Set oBk = ActiveWorkbook
   Application.DisplayAlerts = False
   Dim i As Long
   For i = 1 To oBk.Worksheets.Count
       With oBk.Sheets(i)
         .AutoFilterMode = False
       End With
   Next
   ' work through sheets
   For Each ws In oBk.Worksheets
       If ws.Name Like "*ComResp*" Then
         With ws.Range("A6").CurrentRegion
         Rws = .Rows.Count
         .Offset(2, 0).Resize(Rws - 1).Copy
         End With
         With ThisWorkbook.Sheets(2).Range("A65536").End(xlUp)(2)
         .PasteSpecial Paste:=xlPasteValues
         .PasteSpecial Paste:=xlPasteFormats
         Application.CutCopyMode = False
         End With
       End If
   Next ws
   ThisWorkbook.Sheets(2).Activate
   oBk.Close False
End Sub



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

QUESTION: Sorry, one last question.  As I mentioned in my previous reply code works perfectly when I test it when files are in a folder on a file share. I may also have a situation when files are in a folder within a Sharepoint document library.

I tried to just adjust sPath function to:

sPath = "http://intranet.hntb.org/sites/portal/project1/comresptest/crlibrary/Test/"

but I get an error when I try to run macro. Also it didn't run with original code when in Sharepoint. Thanks, Mark.

Answer
Hi Mark,

The code I gave you can only list files in a "normal" directory located either on a local drive or a network share os an external drive. It cannot handle internet style addresses.

I have searched fora a bit and found some code here:

http://www.mrexcel.com/forum/excel-questions/511617-sharepoint-library-visual-ba

Perhaps you can use that to include it in your code?
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


Jan Karel Pieterse

Expertise

Excel and Excel/VBA questions

Experience

Excel MVP

Organizations
Self employed Excel developer

Education/Credentials
Bachelor in Chemical Engineering

Awards and Honors
Microsoft MVP award since 2002

Past/Present Clients
Shell, Fortis bank, ABN-AMRO bank, Morgan Stanley, ...

©2016 About.com. All rights reserved.