Results 1 to 2 of 2
  1. #1
    New Lounger
    Join Date
    Apr 2014
    Posts
    1
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Open multiple workbooks based on cell values and copy and paste information

    Hi,

    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:
    http://windowssecrets.com/forums/showthread.php/138467-Copy-Multiple-excel-file-to-one-master
    -, closest to what I am trying to do.

    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
    In short this code looks at a certain directory and opens all xlsx files and copies everything into master... Fantastic... But then

    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.

    Egemen
    Attached Files Attached Files

  2. #2
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 341 Times in 334 Posts
    Does this do what you want?
    Code:
    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
    Steve
    Last edited by sdckapr; 2014-04-24 at 13:45.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •