Multiple excel files and collating specific cell info

Hi,

See the attached file. It will pick up all data in cell B2 of every file in the same workbook as the active workbook is in.

Let me know if you have any questions about this.

Succes,
Erik

Hi Khuram,

In the code, which you'll find in the object 'ThisWorkbook', the following line has to be changed :

ActiveSheet.Range("H" & counter).Value = "=+'" & ActiveWorkbook.Path & "\[" & f1.Name & "]Blad1'!$B$2"

The part "Blad1" refers to the name of the sheet. "Blad1" is the Dutch version of the standard sheetname "Sheet1".

Erik

hi ska.

this code will need to be changed in the main code. put the path where all your workbookes are kepted.

.LookIn = "C:\MyDocuments\TestResults"

change this part of the code ie f5 to where the data is you want to copy from
i have used 4 cells on my example
add more for the more cells you have to copy

 rCell.Offset(2, 0).FormulaR1C1 = wbResults.Sheets(1).Range("f5")

ub RunCodeOnAllXLSFiles()
    Dim lCount As Long
    Dim wbResults As Workbook
    Dim wbCodeBook As Workbook
    Dim rCell As Range
     
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
     
    On Error Resume Next
     
    Set wbCodeBook = ThisWorkbook
     
    With Application.FileSearch
        .NewSearch
         'Change path to suit
          .LookIn = "C:\MyDocuments\TestResults"
        .FileType = msoFileTypeExcelWorkbooks
         '.Filename = "Book*.xls"
         
        If .Execute > 0 Then 'Workbooks in folder
            For lCount = 1 To .FoundFiles.Count 'Loop through all.
                 'Open Workbook x and Set a Workbook variable to it
                Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                 
                 'DO YOUR CODE HERE
                Set rCell = wbCodeBook.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
                
                'THIS PUT THE NAME OF THE WORKBOOKS YOU ARE GETTING YOUR DATA FROM INTO A1
              rCell.FormulaR1C1 = ActiveWorkbook.Name
                
                ' THIS PUTS THIS WILL PUT THE DATA IN ROW 1 COLUMN A,B,C,D, ETC AFTER GETTING IT FROM THE CELLS YOU SPECIFY
                
'
 

                rCell.Offset(1, 0).FormulaR1C1 = wbResults.Sheets(1).rCell.Offset(1, 0)
                rCell.Offset(2, 0).FormulaR1C1 = wbResults.Sheets(1).Range("f5")
                rCell.Offset(0, 3).FormulaR1C1 = wbResults.Sheets(1).Range("f6")
                rCell.Offset(0, 4).FormulaR1C1 = wbResults.Sheets(1).Range("f7")
              
                
                
                
                wbResults.Close SaveChanges:=True
                 
            Next lCount
            
        End If
    End With
    ActiveWorkbook.Save
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
   
End Sub

hope this works
this file will have to be in a different location to all the other files

steve