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

[trentbaby9]

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!

 

[Fluff]

What sheet of the Master workbook do you want to copy the values to?
Also will the code be in the master workbook?

 

[trentbaby9]

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

 

[Johnny C]

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.

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

 

[Fluff]

Ok, how about

Sub trentbaby()
   Dim Pth As String
   Dim Fname As String
   Dim Wbk As Workbook
   Dim Ws As Worksheet
   
   Application.ScreenUpdating = True
   Pth = "[COLOR=#ff0000]C:\MrExcel\Fluff\[/COLOR]"
   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 \

 

[trentbaby9]

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"

 

[Fluff]

Oops, missed a bit

Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = Wbk.Sheets("Summary").Range("A11:E11")[COLOR=#ff0000].Value[/COLOR]

 

[trentbaby9]

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)

 

[Fluff]

Are all the files new style workbooks, ie with an extension of xlsx, xlsm or xlsb?

 

[trentbaby9]

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