Import values from other files in folder

Hello - Thanks for taking the time to read this thread.

I need a macro that imports the value from a specific cell from all the spreadsheets in the same folder as the workbook running the code.

This is my "failed" attemp. It works on my pc but doesn't work on other people's pc (they have older versions of excel). So I guess there must be a much better way to do this

'Declare variables
Dim WBK As Workbook
Dim WS As Worksheet
Dim RngToCopy As Range, RngToPaste As Range
'Set variables
Set WS = ActiveSheet
Set FileSystemObj = CreateObject("Scripting.FileSystemObject")
Set FolderObj = FileSystemObj.GetFolder(Application.ThisWorkbook.Path)

Application.ScreenUpdating = False: Application.DisplayAlerts = False: ActiveSheet.DisplayPageBreaks = False: Application.Calculation = xlCalculationManual
'Start loop
    For Each fileObj In FolderObj.Files
        If FileSystemObj.GetExtensionName(fileObj.Path) = "xlsx" Then 'My attempt to make a quick fix to exclude thisworkbook from the loop
            Set WBK = Workbooks.Open(fileObj.Path)
            Set ImpVal = WBK.Worksheets("Efficiency").[I4] 'Import Value from cell
            Set RngToPaste = WS.[A500].End(xlUp).Offset(1, 0) 'Set the target for the pasting
                With ImpVal 'Only copy value and not formulas
                    .Value = .Value
                End With
            Set RngToCopy = ImpVal 'Set the range to be copied
            RngToCopy.Copy Destination:=RngToPaste 'Copy
            WBK.Close Savechanges:=False
        End If
    Next fileObj
Application.DisplayAlerts = True: Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

What I lack the skills to do
I would really like a code that could import the value from cell: Worksheets("Efficiency").[I4], from any spreadsheet in the same folder as thisworkbook no matter what fileextension it has if the spreadsheet has a value in that cell (should of course skip looking in the spreadsheet running the code, which will be in the same folder as the different status reports).
It would be great if the code could detect the users application.screenupdating status and set it to their prior setting after the code (no clue if this is possible).

Hi
In your code trying change "xlsx" to "xl*". This should fix your issue.
Tony

After some trial and error I ended up with this code that works

Sub ImportWorkbooks()

Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim WS As Worksheet
Dim RngToCopy As Range, RngToPaste As Range
Set WS = ActiveSheet

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Get the folder object associated with the import file
Set objFolder = objFSO.GetFolder(Application.ThisWorkbook.Path)

'Loop through the Files collection and import each workbook
For Each objFile In objFolder.Files
    If objFile <> ThisWorkbook.FullName Then
        Dim source As Workbook
        Set source = Application.Workbooks.Open(objFile.Path, ReadOnly:=True)
        If Not source.Worksheets("Effektivitet").[I4] Is Nothing Then
            Set ImpVal = source.Worksheets("Efficiency").[I4] 'Import Value from cell
            Set RngToPaste = WS.[A500].End(xlUp).Offset(1, 0) 'Set the target for the pasting
                With ImpVal 'Only copy value and not formulas
                    .Value = .Value
                End With
            Set RngToCopy = ImpVal 'Set the range to be copied
            RngToCopy.Copy destination:=RngToPaste 'copy/paste
            source.Close Savechanges:=False
            Set source = Nothing
        End If
    End If
Next objFile

Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing

End Sub

Still have some small things on my to do list but I'm pretty satisfied so far

Hi Tony

Just tried change "xlsx" to "xl*" but it cycles through the spreadsheets without opening them, doesn't seem that the wildcard works AND this would also try to open the excel file running the code, which is in the same folder - and that would stop the code from running

Hi
Thanks for the feedback. Pleased you managed to resolve your issue.
Tony

The final code looks like this if anyone else is facing the same issues

Sub ImportWorkbooks()

'Declare variables
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim ImportValue As Range, RngToCopy As Range, RngToPaste As Range
Dim Answer As String, MyNote As String, MyEF As String
Dim ExcludedFiles As Variant
Dim WS As Worksheet
Dim LR As Long

Set WS = ActiveSheet
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Get the folder object associated with the import file
Set objFolder = objFSO.GetFolder(Application.ThisWorkbook.Path)

Application.ScreenUpdating = False: Application.DisplayAlerts = False

'   Delete current data to avoid double entries
    With WS
        If .[a2] <> Empty Then
            MyNote = "Current data detected do you want to delete this data to avoid double entries?"
            Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "Delete data?")
            If Answer = vbNo Then GoTo StartLoop
            LR = .Range("A" & Rows.Count).End(xlUp).Row
            With .Range("A2:A" & LR)
                .ClearContents
            End With
        End If
    End With
    
StartLoop:
'   Loop through the Files collection and import values from each workbook from cell I4 on Effektivitet sheet
    For Each objFile In objFolder.Files
'       Exclude workbook running the code from the loop
        If objFile <> ThisWorkbook.FullName Then
            Dim source As Workbook
            Set source = Application.Workbooks.Open(objFile.Path, ReadOnly:=True)
            If WorksheetExists("Effektivitet") Then
                Set ImpVal = source.Worksheets("Effektivitet").[I4] 'Range that are imported
                If Not ImpVal Is Nothing Then
                        WS.[A500].End(xlUp).Offset(1).Value = ImpVal.Value 'Insert range on first empty row in colomn A
                        IncludedFiles = IncludedFiles & ", " & ActiveWorkbook.Name
                End If
            Else
            ExcludedFiles = ExcludedFiles & ActiveWorkbook.Name & " "
            End If
            source.Close
            Set source = Nothing
        End If
    Next objFile

Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing

'Show which files weren't succesfully imported from the source folder
If ExcludedFiles <> Empty Then
    MyEF = "The following files wasn't imported succesfully: " & ExcludedFiles
    MsgBox MyEF, vbExclamation, "Some files didn't fit the criterias for importing values"
End If

Application.DisplayAlerts = True: Application.ScreenUpdating = True

End Sub

Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
    WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function