Page 1 of 2 1 2 LastLast
Results 1 to 10 of 14

Thread: copy cell from multiple worksheets saved in multiple sub-folders

  1. #1

    copy cell from multiple worksheets saved in multiple sub-folders



    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hi,

    I'm a total beginner with VBA and have only been able to develop the code attached through research alone and not through my own knowledge.

    I'm after some help as I'm stuck for a solution; I want to enter a code in a master workbook that can search for excel workbooks through multiple sub-folders contained within a folder, and then copy a particular cell from every workbook found and paste the value into the master workbook.

    The code below works fine (copies and pastes cell D9 from the workbooks found into the master workbook), however it only searches through the sub-folder named ("TA1 BASEMENT"). I want a code that starts searching from the folder "Guardrails & Gratings" onwards.

    Can anyone help me with this? Any help would be much appreciated!!

    --------------------------------------------------- CODE SO FAR -------------------------------
    Sub Copy_Paste()

    Dim MyFolder As String
    Dim MyFile As String
    Dim NewR As Range

    MyFolder = "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Handrails Inspections 2013\Guardrails & Gratings\Schedule 8 Turb Hall\Basement\TA1 BASEMENT"
    MyFile = Dir(MyFolder & "\*.xlsx")

    Do While MyFile <> ""
    ' open the source workbook and select the source sheet
    Workbooks.Open Filename:=MyFolder & "\" & MyFile
    Sheets("0609188").Select
    ' copy the source range
    Sheets("0609188").Range("D9").Select
    Selection.Copy
    ' select current workbook and paste the values starting at B2
    Windows("Master File - A.xlsm").Activate
    Sheets("Sheet1").Select
    Set NewR = ActiveSheet.Range("B" & ActiveSheet.Cells.Rows.Count).End(xlUp).Offset(1, 0)
    NewR.PasteSpecial xlPasteValues
    ActiveWorkbook.Save
    MyFile = Dir
    Loop

    ' This sub will close all workbooks except the workbook in which the code is located.
    Dim WkbkName As Object
    On Error GoTo Close_Error
    Application.ScreenUpdating = False
    For Each WkbkName In Application.Workbooks()
    If WkbkName.Name <> ThisWorkbook.Name Then WkbkName.Close
    Next
    ' If everything runs all right, exit the sub.
    Exit Sub
    ' Error handler.
    Close_Error:
    MsgBox Str(Err) & " " & Error()
    Resume Next

    End Sub

  2. #2
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    675
    Articles
    0
    Excel Version
    Excel 2010 64bit
    Goggling this indicates it to be a common "problem" for people.
    Your routine only searches through the sub-folder named "TA1 BASEMENT" because that is exactly what it is being asked to do.

    This link, although dealing with Access, provides some VBA adapted by well known expert that will be of interest.
    http://www.ammara.com/access_image_f...er_search.html

  3. #3
    Hi,

    I should have explained myself a bit better; I understand the code as it is will not search through the subfolder, only through the folder its being asked to. I was however hoping that there may be a simple way to adapt what I currently have so that it searches the subfolders.

    I've tried adapting it using the information provided in the link but I'm having no luck, as I said I am completely new to this!!

    I there anyone able to help me with this?!

    Thanks!

  4. #4
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    675
    Articles
    0
    Excel Version
    Excel 2010 64bit
    gwyn_123, hi

    Your original post indicates you can do what you want with each file, you just can't find them. The function I linked to does this nicely. Try this.

    Open a new Excel workbook. Alt-F11 to get to the VBA environment. Insert a module. Copy and paste the 2 functions from the provided linked page to this module.

    Now the example on the page needs put into a sub with the folder you want to start at and the file type you want to deal with. Paste this sub into the same module and run it. It will display the name of every file you will be dealing with.


    Code:
    Sub Find_all_Files()
        Dim colFiles As New Collection
        Dim vFile As Variant
        
        RecursiveDir colFiles, "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Handrails Inspections 2013\Guardrails & Gratings", "*.xlsx", True
    
        For Each vFile In colFiles
        'do what ever is needed with each file here
        'Ctrl+g brings up the Immediate Window where you can see the file names printed out
            Debug.Print vFile
        Next vFile
        
    End Sub
    Hope this is of some assistance.
    NoS

  5. #5
    Hi NoS,

    I think I've done what you suggested (see code below) but nothing seems to happen. I get no error messages but I get no output either!

    Please excuse me if I'm missing something really obvious!

    Thanks,
    Gwyn

    -------------------------------------------------------------------------------
    Public Function RecursiveDir(colFiles As Collection, _
    strFolder As String, _
    strFileSpec As String, _
    bIncludeSubfolders As Boolean)
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant
    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
    colFiles.Add strFolder & strTemp
    strTemp = Dir
    Loop
    If bIncludeSubfolders Then
    'Fill colFolders with list of subdirectories of strFolder
    strTemp = Dir(strFolder, vbDirectory)
    Do While strTemp <> vbNullString
    If (strTemp <> ".") And (strTemp <> "..") Then
    If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
    colFolders.Add strTemp
    End If
    End If
    strTemp = Dir
    Loop
    'Call RecursiveDir for each subfolder in colFolders
    For Each vFolderName In colFolders
    Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
    Next vFolderName
    End If
    End Function
    Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
    If Right(strFolder, 1) = "\" Then
    TrailingSlash = strFolder
    Else
    TrailingSlash = strFolder & "\"
    End If
    End If
    End Function
    Sub Find_all_Files()
    Dim colFiles As New Collection
    Dim vFile As Variant

    RecursiveDir colFiles, "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Handrails Inspections 2013\Guardrails & Gratings", "*.xlsx", True
    For Each vFile In colFiles
    ' open the source workbook and select the source sheet
    Sheets("0609188").Select
    ' copy the source range
    Sheets("0609188").Range("D9").Select
    Selection.Copy
    ' select current workbook and paste the values starting at B2
    Windows("Master File - B.xlsm").Activate
    Sheets("Sheet1").Select
    Set NewR = ActiveSheet.Range("B" & ActiveSheet.Cells.Rows.Count).End(xlUp).Offset(1, 0)
    NewR.PasteSpecial xlPasteValues
    ActiveWorkbook.Save
    'Ctrl+g brings up the Immediate Window where you can see the file names printed out
    Debug.Print vFile
    Next vFile

    End Sub

  6. #6
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    675
    Articles
    0
    Excel Version
    Excel 2010 64bit
    Hello Gwyn,

    The way things work with this function is that the function compiles a collection of all the file names as specified that are contained in the folder and sub folders. You then need to create your own sub routine to deal with those files. In the previous example sub, the For Each portion steps through the file names one at a time, it is only looking at the file name not "inside" the file. The part you are missing is opening each file to get the info you're after as the For Each cycles through the collection of file names.

    Try this sub. I've used a different sub name to distinguish between them.

    Code:
    Sub Collect_Info()
        Dim colFiles As New Collection
        Dim vFile As Variant
        
        RecursiveDir colFiles, "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Handrails Inspections 2013\Guardrails & Gratings", "*.xlsx", True
        
    'Application.EnableEvents = False    'turn off events
    'Application.ScreenUpdating = False  'turn off screen updating
    
        For Each vFile In colFiles
        'open the current vFile workbook
        Workbooks.Open (vFile)
        'select the sheet in vFile to retrieve info from
        'Sheets("0609188").Range("D9").Select
            Sheets("0609188").Select
            with activesheet
                 .Cells(9, 4).Select
                Selection.Copy
            end with    
            
        'come back to this workbook
        Windows("Master File - B.xlsm").Activate
        'find the first available row in col B on sheet 1
        Sheets("Sheet1").Select
            With ActiveSheet
                Cells(.Cells(.Rows.Count, "B").End(xlUp).Row + 1, 2).Select
                'paste copied selection here
                ActiveSheet.Paste
                'just to move cursor to a neutal location
                Cells(1, 1).Select
            End With
            
            'go back to vFile and close it
            'need file name without the path
            Windows(Dir(vFile)).Activate
            Application.CutCopyMode = False
            ActiveWorkbook.Close
        
    Next vFile
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    End Sub

    Create a break point at the For Each line and then use F8 to step through and see what is actually going on. If/when you are satisfied with things uncomment the enable.events and screenupdating to speed things up.

    Good luck
    NoS

  7. #7
    Hi NoS,

    Thanks for all your help so far! Nearly there now, just one slight issue and I have no idea why this happens:

    In the code below, when it is asked to copy cell D9 / cell (9, 4) it only copies and pastes from the last file it searches through. However when I experimented and changed the macro to cpoy cell I4 / cell (4, 9) it worked perfectly and copied and pasted from all files in all sub-folders.

    Why would it do this? If it helps, cell D9 will always be of a different value but cell I4 is always constant i.e. will always contain the text "Location:". Is the code dependant on the files having the same value?

    Nearly there, it would be massively appreciated if you could help me with this final problem!

    Many thanks,
    gwyn_123

    ---------------------------------------------------------------------------------------------------------------------------------------------
    Public Function RecursiveDir(colFiles As Collection, _
    strFolder As String, _
    strFileSpec As String, _
    bIncludeSubfolders As Boolean)
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant
    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
    colFiles.Add strFolder & strTemp
    strTemp = Dir
    Loop
    If bIncludeSubfolders Then
    'Fill colFolders with list of subdirectories of strFolder
    strTemp = Dir(strFolder, vbDirectory)
    Do While strTemp <> vbNullString
    If (strTemp <> ".") And (strTemp <> "..") Then
    If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
    colFolders.Add strTemp
    End If
    End If
    strTemp = Dir
    Loop
    'Call RecursiveDir for each subfolder in colFolders
    For Each vFolderName In colFolders
    Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
    Next vFolderName
    End If
    End Function
    Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
    If Right(strFolder, 1) = "\" Then
    TrailingSlash = strFolder
    Else
    TrailingSlash = strFolder & "\"
    End If
    End If
    End Function
    Sub Collect_Info()
    Dim colFiles As New Collection
    Dim vFile As Variant

    RecursiveDir colFiles, "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Guardrails Inspections 2013\Guardrails & Gratings", "*.xlsx", True

    Application.EnableEvents = False 'turn off events
    Application.ScreenUpdating = False 'turn off screen updating
    For Each vFile In colFiles

    'open the current vFile workbook
    Workbooks.Open (vFile)
    'select the sheet in vFile to retrieve info from
    'Sheets("0609188").Range("D9").Select
    Sheets("0609188").Select
    With ActiveSheet
    .Cells(9, 4).Select
    Selection.Copy
    End With

    'come back to this workbook
    Windows("Master File - B.xlsm").Activate
    'find the first available row in col B on sheet 1
    Sheets("Sheet1").Select
    With ActiveSheet
    Cells(.Cells(.Rows.Count, "B").End(xlUp).Row + 1, 2).Select
    'paste copied selection here
    ActiveSheet.Paste
    'just to move cursor to a neutal location
    Cells(1, 1).Select
    End With

    'go back to vFile and close it
    'need file name without the path
    Windows(Dir(vFile)).Activate
    Application.CutCopyMode = False
    ActiveWorkbook.Close

    Next vFile
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End Sub

  8. #8
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    675
    Articles
    0
    Excel Version
    Excel 2010 64bit
    it only copies and pastes from the last file it searches through
    That doesn't make sense. The routine does exactly the same thing every time for every file.

    I'd trouble shoot it by putting a break point at the line right after the line you have in red. This will stop execution of the routine at this point every time through and allow you to look at the workbooks currently open to see what has actually been selected. Then use F5 to continue one line at a time and keep looking to see what actually is or isn't happening.

    Out of curiosity, how many files are you extracting information from in your subfolders?

  9. #9
    Hi NoS,

    Problem solved, I changed the code to paste the value only and not the cell format.

    Iím very happy with how the code currently works but it would be improved if I could make the following change. Currently when I run the macro it pastes the copied values in the next available cell in the desired column (OK so far). But when I re-run the macro it pastes the values as a continuation of the previous values; is there any way to paste the values starting from the same cell (i.e. the next available cell presuming the macro had not yet been run) however many times the macro is run i.e. overwrites the previously pasted values.

    Many thanks,
    gwyn_123

    --------------------------------------

    Public Function RecursiveDir(colFiles As Collection, _
    strFolder As String, _
    strFileSpec As String, _
    bIncludeSubfolders As Boolean)
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant
    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
    colFiles.Add strFolder & strTemp
    strTemp = Dir
    Loop
    If bIncludeSubfolders Then
    'Fill colFolders with list of subdirectories of strFolder
    strTemp = Dir(strFolder, vbDirectory)
    Do While strTemp <> vbNullString
    If (strTemp <> ".") And (strTemp <> "..") Then
    If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
    colFolders.Add strTemp
    End If
    End If
    strTemp = Dir
    Loop
    'Call RecursiveDir for each subfolder in colFolders
    For Each vFolderName In colFolders
    Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
    Next vFolderName
    End If
    End Function
    Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
    If Right(strFolder, 1) = "\" Then
    TrailingSlash = strFolder
    Else
    TrailingSlash = strFolder & "\"
    End If
    End If
    End Function
    Sub PlatformID()
    Dim colFiles As New Collection
    Dim vFile As Variant
    Dim NewR As Range

    RecursiveDir colFiles, "Y:\Syseng\Conventional Systems\Civil Systems\Ladder & Guardrails Inspections 2013\Guardrails & Gratings", "*.xlsx", True

    Application.EnableEvents = False 'turn off events
    Application.ScreenUpdating = False 'turn off screen updating
    For Each vFile In colFiles

    'open the current vFile workbook
    Workbooks.Open (vFile)
    'select the sheet in vFile to retrieve info from
    'Sheets("0609188").Range("D9").Select
    Sheets("0609188").Select
    With ActiveSheet
    .Cells(5, 10).Select
    Selection.Copy
    End With

    'come back to this workbook
    Windows("Master - Guardrails & Gratings.xlsm").Activate
    'find the first available row in col B on sheet 1
    Sheets("Sheet1").Select
    With ActiveSheet
    Set NewR = ActiveSheet.Range("B" & ActiveSheet.Cells.Rows.Count).End(xlUp).Offset(1, 0)
    'paste copied selection here
    NewR.PasteSpecial xlPasteValues
    'just to move cursor to a neutal location
    Cells(1, 1).Select
    End With

    'go back to vFile and close it
    'need file name without the path
    Windows(Dir(vFile)).Activate
    Application.CutCopyMode = False
    ActiveWorkbook.Close

    Next vFile
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End Sub

  10. #10
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    675
    Articles
    0
    Excel Version
    Excel 2010 64bit
    Sure Gwyn you can do that.

    In the For Each loop, you currently use NewR for the next available row to paste to every time through the loop.
    You will need to change that so you specify the cell to paste to the first time through the loop and then increment row offset for additional loops.

    Be aware that deleting, adding or changing location of files you are reading info from will mean that the info is not necessarily written into the same cell.

    Good luck with your project
    NoS

Page 1 of 2 1 2 LastLast

Posting Permissions

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