2014-04-23, 06:23 #1
- Join Date
- Apr 2014
- Thanked 0 Times in 0 Posts
Open multiple workbooks based on cell values and copy and paste information
I have about 160 different workbooks and I need to collect that information and consolidate them in one workbook.
What I am trying to do is that;
1.) Create a master Workbook with ~160 worksheets (One worksheet for each unit) named exactly the same with other workbooks
2.) And macro can pull the information from related files stored in a certain folder
There can be multiple sheets in source workbooks and ideally I like to run this from a list as each file would have a different password.
I found below code here posted by sdckapr (Steve) -HTML Code:
Sub CopyWorksheets() ' Path - modify as needed but keep trailing backslash Const sPath = "\\C\Ege\" Dim sFile As String Dim wbkSource As Workbook Dim wSource As Worksheet Dim wbkTarget As Workbook On Error GoTo ErrHandler Application.ScreenUpdating = False Set wbkTarget = ActiveWorkbook sFile = Dir(sPath & "*.xlsx*") Do While Not sFile = "" Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False) For Each wSource In wbkSource.Worksheets With wbkTarget wSource.Copy After:=.Sheets(.Sheets.Count) End With Next wbkSource.Close SaveChanges:=False sFile = Dir Loop ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description, vbExclamation Resume ExitHandler End Sub
1.) I have an issue with password. Lets say I will find a way around this.
2.) I only want to copy a specific worksheet from each workbooks (All same name) and not all worksheets.
3.) Also just for ease of use can I put a reference to a cell for the directory rather than keeping it in the code
just spent hours on this and found lots of different solutions but not exactly what I needed.
I attach the workbook exactly explains what I am trying to achieve.
I would really appreciate any help.
Thanks in Advance.
Subscribe to our Windows Secrets Newsletter - It's Free!
Get our unique weekly Newsletter with tips and techniques, how to's and critical updates on Windows 7, Windows 8, Windows XP, Firefox, Internet Explorer, Google, etc. Join our 480,000 subscribers!
+ Get this BONUS — free!
Get the most of Excel! Learn about new features, basics of creating a new spreadsheet and using the infamous Ribbon in the first chapter of Excel 2013: The Missing Manual - Subscribe and download Chapter 1 for free!
2014-04-24, 13:12 #2
- Join Date
- Jul 2002
- Pittsburgh, Pennsylvania, USA
- Thanked 325 Times in 319 Posts
Does this do what you want?
Option Explicit Sub CopyWorksheets() ' Path - modify as needed but keep trailing backslash Const sPath = "C:\General\finance\00 FINANCE\Project Management\Projects\PRAE-15 - PR1 Reporting\Test" Const sComp = "Complete" Const sInc = "Not Found" Const lRowStart = 4 Const iName = 1 'Col A Const iSheet = 2 'Col B Const iRange = 3 'Col C Const iExt = 4 'Col D Const iPwd = 5 'Col E Const iComp = 6 'Col F Dim sDir As String Dim sFile As String Dim sPwd As String Dim wbkSource As Workbook Dim rSource As Range Dim sWks As String Dim sRng As String Dim wbkTarget As Workbook Dim wTarget As Worksheet Dim wList As Worksheet Dim lRowEnd As Long Dim lRow As Long On Error GoTo ErrHandler Application.ScreenUpdating = False 'Set these as desired Set wbkTarget = ActiveWorkbook Set wList = wbkTarget.Worksheets("List") With wList 'get the last row lRowEnd = .Cells(.Rows.Count, iName).End(xlUp).Row 'Clear the Complete/Incomplete column .Range(.Cells(lRowStart, iComp), .Cells(lRowEnd, iComp)).ClearContents 'loop through the list For lRow = lRowStart To lRowEnd 'Get filename, password, worksheet name, and range sFile = sPath & .Cells(lRow, iName) & .Cells(lRow, iExt) sPwd = .Cells(lRow, iPwd) sWks = .Cells(lRow, iSheet) sRng = .Cells(lRow, iRange) sDir = Dir(sFile) If sDir = "" Then 'file does not exist, mark as inc .Cells(lRow, iComp) = sInc Else 'file exists 'open the workbook Set wbkSource = Workbooks.Open(Filename:=sFile, Password:=sPwd, ReadOnly:=True, AddToMRU:=False) 'delete worksheet if it already exists Application.DisplayAlerts = False On Error Resume Next wbkTarget.Worksheets(sWks).Delete On Error GoTo ErrHandler Application.DisplayAlerts = True 'create new worksheet With wbkTarget Set wTarget = .Worksheets.Add wTarget.Move After:=.Sheets(.Sheets.Count) End With wTarget.Name = sWks 'copy the range wbkSource.Worksheets(sWks).Range(sRng).Copy wTarget.Range("A1") 'mark as complete .Cells(lRow, iComp) = sComp wbkSource.Close (False) End If Next End With 'Let them know you are done MsgBox "All Done" ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description, vbExclamation Resume ExitHandler End Sub
Last edited by sdckapr; 2014-04-24 at 13:45.