Results 1 to 7 of 7
  1. #1
    Lounger
    Join Date
    Apr 2014
    Posts
    37
    Thanks
    2
    Thanked 1 Time in 1 Post

    Copy Data From Multiple Files in different locations

    Hello,

    I need to copy some cells form different excel files , i.e. data_user_1.xlsx, data_user_2.xlsx, data_user_3.xlsx, etc to ONE file only.

    But the file are in different locations, i.e D:\Documents\User1\*.xlsx, D:\Documents\User2\*.xlsx, D:\Documents\User3\*.xlsx, etc.

    I'm using Excel 2007.

    This code for ONE location works fine:

    ----------------------------------------
    Option Explicit
    Sub DailyCheckUpt()
    'List all the files that are not updated (criteira)

    ' Path - modify as needed but keep trailing backslash
    Const sPath = "D:\Documents\"

    Dim sFile As String
    Dim wbkSource As Workbook
    Dim wSource As Worksheet
    Dim wTarget As Worksheet
    Dim lRows As Long
    Dim lMaxSourceRow As Long
    Dim lMaxTargetRow As Long

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    Set wTarget = ActiveSheet
    lRows = wTarget.Rows.Count
    sFile = Dir(sPath & "*.xlsx*")

    Do While Not sFile = ""
    Set wbkSource = Workbooks.Open(FileName:=sPath & sFile, AddToMRU:=False)
    Set wSource = wbkSource.Worksheets(1)
    lMaxSourceRow = wSource.Cells(lRows, 1).End(xlUp).Row
    lMaxTargetRow = wTarget.Cells(lRows, 1).End(xlUp).Row

    'Copy Dispenser Code only from the files that are NOT updated
    If wbkSource.Sheets("1").Range("B11") <> "OK" Then
    wTarget.Cells(lMaxTargetRow + 1, 1) = wbkSource.Sheets("1").Range("B2").Value

    End If

    wbkSource.Close SaveChanges:=False
    sFile = Dir

    Loop

    ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

    ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler

    End Sub
    ----------------------------------------

    What changes need to do to read several locations?

    Many thanks


    LL

  2. #2
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts
    Do these changes do what you want?
    Code:
    Dim x As Integer
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Set wTarget = ActiveSheet
    lRows = wTarget.Rows.Count
    For x = 1 To 3 'change number as needed
    sFile = Dir(sPath & "User" & x & "\*.xlsx")
    Do While Not sFile = ""
    Set wbkSource = Workbooks.Open(Filename:=sPath & "User" & x & "\" & sFile, AddToMRU:=False)
    Set wSource = wbkSource.Worksheets(1)
    lMaxSourceRow = wSource.Cells(lRows, 1).End(xlUp).Row
    lMaxTargetRow = wTarget.Cells(lRows, 1).End(xlUp).Row
    
    'Copy Dispenser Code only from the files that are NOT updated
    If wbkSource.Sheets("1").Range("B11") <> "OK" Then
    wTarget.Cells(lMaxTargetRow + 1, 1) = wbkSource.Sheets("1").Range("B2").Value
    
    End If
    
    wbkSource.Close SaveChanges:=False
    sFile = Dir
    
    Loop
    Next x
    Steve

  3. #3
    Lounger
    Join Date
    Apr 2014
    Posts
    37
    Thanks
    2
    Thanked 1 Time in 1 Post
    Hi Steve,

    Many thanks for the help that work's just fine for that folder structure.

    What needs to be changed if the folder structure have diffrent names? Like:
    D:\Documents\John Master
    D:\Documents\Many
    D:\Documents\Steve Merlin
    ....

    I've tried some combinations but I could find a working one..

  4. #4
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts
    You can create an Array
    You can add these lines:
    dim vArray as variant
    vArray = Array("John Master", "Many", "Steve Merlin")

    Then change these lines:
    sFile = Dir(sPath & Varray(x) & "\*.xlsx")
    Set wbkSource = Workbooks.Open(Filename:=sPath & Varray(x) & "\" & sFile, AddToMRU:=False)

    Steve

  5. #5
    Lounger
    Join Date
    Apr 2014
    Posts
    37
    Thanks
    2
    Thanked 1 Time in 1 Post
    Sorry Steve but I didn't explained my self correctly...

    Those 3 folder names are only examples because the folder list can go over 200 folders.

    How can I create a array to look in all the folders?


    LL

  6. #6
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts
    How about something like these changes?

    Code:
    Dim oFSO As Object
    Dim oFolder As Object
    Dim oSubFolder As Object
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(sPath)
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Set wTarget = ActiveSheet
    lRows = wTarget.Rows.Count
    
    For Each oSubFolder In oFolder.SubFolders
    sFile = Dir(oSubFolder & "\*.xlsx")
    
    Do While Not sFile = ""
    Set wbkSource = Workbooks.Open(Filename:=oSubFolder & "\" & sFile, AddToMRU:=False)
    Set wSource = wbkSource.Worksheets(1)
    lMaxSourceRow = wSource.Cells(lRows, 1).End(xlUp).Row
    lMaxTargetRow = wTarget.Cells(lRows, 1).End(xlUp).Row
    
    'Copy Dispenser Code only from the files that are NOT updated
    If wbkSource.Sheets("1").Range("B11") <> "OK" Then
    wTarget.Cells(lMaxTargetRow + 1, 1) = wbkSource.Sheets("1").Range("B2").Value
    
    End If
    
    wbkSource.Close SaveChanges:=False
    sFile = Dir
    
    Loop
    Next
    Steve

  7. #7
    Lounger
    Join Date
    Apr 2014
    Posts
    37
    Thanks
    2
    Thanked 1 Time in 1 Post
    This is PERFECT!!

    Million thanks Steve

    LL

Posting Permissions

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