Page 1 of 2 12 LastLast
Results 1 to 10 of 17

Thread: VBA for copy/paste values of all workbooks in a folder

  1. #1
    New Member
    Join Date
    Feb 2013
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Question VBA for copy/paste values of all workbooks in a folder

    I'm trying to find and figure out the vba code needed to copy selected cells from all workbooks in a folder and paste the values only into the new "master summary" workbook, incrementing each pasted value to the next available line. I've tried several different codes but still can't seem to get any of them to work.

    Folder = Test Folder
    Files in Folder: file1.xlsx, file2.xlsx, file3.xlsx
    Each file has multiple worksheets, but I only need to copy five cells (A11, B11, C11, D11, E11) from the worksheet labeled Summary.

    I then need to paste values only into the "master summary" workbook on the next available line so that no data is overwritten.

    Any help is greatly appreciated!

  2. #2
    MrExcel MVP
    Moderator
    Fluff's Avatar
    Join Date
    Jun 2014
    Location
    Chippenham
    Posts
    29,229
    Post Thanks / Like
    Mentioned
    483 Post(s)
    Tagged
    49 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    What sheet of the Master workbook do you want to copy the values to?
    Also will the code be in the master workbook?
    - Posting Data try one of these tools
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

    Running Office 365 on Win 10

  3. #3
    New Member
    Join Date
    Feb 2013
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    Right now it's just labeled Sheet1 in the master workbook and yes, the code will be stored in the master workbook.

  4. #4
    Board Regular Johnny C's Avatar
    Join Date
    Nov 2006
    Location
    Liverpool, UK
    Posts
    997
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    This might set you on your way. Note that some sheets have VBA Codenames (wksSupplier) so go into VBA and give your Sheet1 in the master a codename and replace wksSupplier with that codename in the code below.

    It opens all files that begin with the value in strSuppFile you can scrap that but if the master is in the same folder you need to stop it trying to open that.

    Code:
    Option Explicit
    Sub ScanSuppliers()
    Dim X
    Dim strPath$, strFile$, strSuppName$, strThisFile$, strExt$, strTargetSheet$, strSuppFile$, strSuppID$
    Dim strError$
    Dim sglSuppAve!, intRedCount%, intRowCount%, intRowCountOriginal%
    Dim wbTarget As Workbook, wbThisWB As Workbook
    Dim FldrPicker As FileDialog
    
    
    'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    
    strThisFile = ActiveWorkbook.Name
    strTargetSheet = wksSupplier.Range("SuppSheetName").Value
    strSuppFile = wksSupplier.Range("SuppSheetFile").Value
    intRowCount = wksSupplier.Range("RowOne").Value
    intRowCountOriginal = wksSupplier.Range("RowOne").Value
    
    
    'Retrieve Target Folder Path From User
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    
    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.AskToUpdateLinks = True
            MsgBox "No folder chosen"
            Exit Sub
        End If
        strPath = .SelectedItems(1) & "\"
    End With
      
    strPath = strPath
    If strPath = "" Then
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        Application.AskToUpdateLinks = True
        MsgBox "No folder chosen"
        Exit Sub
    End If
    
    
    'Target File Extension (must include wildcard "*")
    strExt = strSuppFile & "*.xls*"
    strFile = Dir(strPath & strExt)
    Set wbThisWB = ActiveWorkbook
    
    On Error Resume Next
    wksSupplier.Range("Data").ClearContents
    On Error GoTo 0
    
    'Loop through each Excel file in folder
    Do While strFile <> ""
        'Set variable equal to opened workbook
        If strFile <> strThisFile Then
            Set wbTarget = Workbooks.Open(Filename:=strPath & strFile)
            If UCase(Left(strFile, Len(strSuppFile))) = UCase(strSuppFile) Then
                strSuppID = Mid(strFile, Len(strSuppFile) + 1, InStrRev(strFile, ".") - Len(strSuppFile) - 1)
                'Ensure Workbook has opened before moving on to next line of code
                DoEvents
                
                'Get information from target workbook
                On Error Resume Next
                Sheets(strTargetSheet).Activate
                If Err.Number <> 0 Then
                    On Error GoTo 0
                    strSuppName = "Not known"
                    sglSuppAve = 0
                    intRedCount = 0
                    strError = "Can't find sheet [" & strTargetSheet & "] in " & strFile
                Else:
                    On Error GoTo 0
                    strSuppName = Cells(2, 3).Value
                    sglSuppAve = Cells(4, 3).Value
                    intRedCount = Cells(6, 3).Value
                    strError = ""
                End If
                        
                'Paste into this workbook
                wbThisWB.Activate
                Sheets("Summary").Activate
                
                Cells(intRowCount, 2).Value = strSuppName
                Cells(intRowCount, 3).Value = sglSuppAve
                Cells(intRowCount, 4).Value = intRedCount
                Cells(intRowCount, 5).Value = strError
                Application.ScreenUpdating = True
                DoEvents
                Application.ScreenUpdating = False
                intRowCount = intRowCount + 1
            End If
            'Save and Close Workbook
              wbTarget.Close SaveChanges:=False
              
            'Ensure Workbook has closed before moving on to next line of code
              DoEvents
        
            'Get next file name
        End If
        strFile = Dir
    Loop
    
    ' If IntRowCount has incremented (i.e. 1 or more files found) then copy match formula down
    If intRowCount <> intRowCountOriginal Then
        Range("MyFormula").Copy
        Range("PopulatedRows").Offset(0, -1).PasteSpecial (xlPasteFormulas)
    End If
    
    'reset system flags
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    Application.Calculation = xlCalculationAutomatic
    Application.CutCopyMode = False
    
    'Message Box when tasks are completed
    If intRowCount <> intRowCountOriginal Then
        MsgBox "All done " & (intRowCount - wksSupplier.Range("RowOne").Value) & " files processed"
    Else
        MsgBox "Could not find any files called 'Supplier HealthCheck - '+supplier name in the folder you chose"
    End If
    Cells(wksSupplier.Range("RowOne").Value, 3).Select
    
    End Sub
    Last edited by Johnny C; Sep 30th, 2019 at 11:23 AM.
    "If you think this Universe is bad, you should see some of the others" - Philip K. DiĘk

  5. #5
    MrExcel MVP
    Moderator
    Fluff's Avatar
    Join Date
    Jun 2014
    Location
    Chippenham
    Posts
    29,229
    Post Thanks / Like
    Mentioned
    483 Post(s)
    Tagged
    49 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    Ok, how about
    Code:
    Sub trentbaby()
       Dim Pth As String
       Dim Fname As String
       Dim Wbk As Workbook
       Dim Ws As Worksheet
       
       Application.ScreenUpdating = True
       Pth = "C:\MrExcel\Fluff\"
       Fname = Dir(Pth & "*.xls*")
       Set Ws = ThisWorkbook.Sheets("Sheet1")
       Do While Fname <> ""
          Set Wbk = Workbooks.Open(Pth & Fname)
          Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = Wbk.Sheets("Summary").Range("A11:E11")
          Wbk.Close False
          Fname = Dir()
       Loop
    End Sub
    Change path in red to suit, but make sure you include the closing \
    - Posting Data try one of these tools
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

    Running Office 365 on Win 10

  6. #6
    New Member
    Join Date
    Feb 2013
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    Fluff,

    I changed the filename and included the closing \ and I can tell it's running, but it isn't pasting any data into the open workbook "master summary workbook"
    Last edited by trentbaby9; Sep 30th, 2019 at 11:37 AM.

  7. #7
    MrExcel MVP
    Moderator
    Fluff's Avatar
    Join Date
    Jun 2014
    Location
    Chippenham
    Posts
    29,229
    Post Thanks / Like
    Mentioned
    483 Post(s)
    Tagged
    49 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    Oops, missed a bit
    Code:
    Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = Wbk.Sheets("Summary").Range("A11:E11").Value
    - Posting Data try one of these tools
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

    Running Office 365 on Win 10

  8. #8
    New Member
    Join Date
    Feb 2013
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    Thanks Fluff!

    It worked, but it only pulled the data from 2 of the 14 files in the folder. The number of files in the folder may change from month to month (not sure if that makes a difference in the code or not)

  9. #9
    MrExcel MVP
    Moderator
    Fluff's Avatar
    Join Date
    Jun 2014
    Location
    Chippenham
    Posts
    29,229
    Post Thanks / Like
    Mentioned
    483 Post(s)
    Tagged
    49 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    Are all the files new style workbooks, ie with an extension of xlsx, xlsm or xlsb?
    - Posting Data try one of these tools
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

    Running Office 365 on Win 10

  10. #10
    New Member
    Join Date
    Feb 2013
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA for copy/paste values of all workbooks in a folder

    Fluff,

    Yes, they are .xlsx files and I changed that in the code you provided.

    Sub trentbaby()
    Dim Pth As String
    Dim Fname As String
    Dim Wbk As Workbook
    Dim Ws As Worksheet

    Application.ScreenUpdating = False
    Pth = "L:\1 - TEGRAEXCEL\PAYROLL\July 2019\DRIVER PAY - JULY 2019"
    Fname = Dir(Pth & "*.xlsx*")
    Set Ws = ThisWorkbook.Sheets("Sheet1")
    Do While Fname <> ""
    Set Wbk = Workbooks.Open(Pth & Fname)
    Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = Wbk.Sheets("Summary").Range("A11:E11").Value
    Wbk.Close False
    Fname = Dir()
    Loop
    End Sub

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

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