Efficient way to copy images and data from multiple source workbook to a single workbook

So the fast solution is here: Turn off Screen Updating and then turn it on again afterwards, I implemented some time measurement in my code to visualize this:

Option Explicit

Sub copy_images_original()

Dim dstWS As Worksheet
Set dstWS = ThisWorkbook.Sheets(1)
Dim srcWB As Workbook
Dim srcWS As Worksheet

Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")

srcWS.Pictures(4).Copy
dstWS.Range("B7").PasteSpecial
srcWB.Close

Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")

srcWS.Pictures(4).Copy
dstWS.Range("G8").PasteSpecial
srcWB.Close
End Sub

Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer

'*****************************
Call turn_app_off
Call copy_images_original
Call turn_app_on
'*****************************

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

Sub turn_app_off()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
End Sub
Sub turn_app_on()
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

What has now improved? Your srcWBs will now be closed, your original source code didnt do that.

In my scenario here, the execution time improved from 2 Secs to 1,4 Secs. So your Code runs 25% faster without much effort.

Hope you find my suggestion fair enough. With best regards

Create a Report

• I was assuming that the destination workbook and the workbook containing this code, ThisWorkbook, are the same.
• Adjust the values in the constants section.
• Run only the createReport procedure. The function getFilePathsInFolder is being called by it.
• Since ThisWorkbook will not have an "xlsx" extension, the statement If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then is redundant, but I'm leaving it because you might one day change the file extension to "xls*" when the code could do some damage.

Abstract

• It will look in the specified folder and write all .xlsx files to an array. It will loop through the array and open each workbook to copy the picture, specified by its index, and paste it and write the specified cell values, to the specified locations of the destination workbook, closing each source workbook afterwards.

The Code

Option Explicit

Sub createReport()
    
    Const ProcName As String = "createReport"
    On Error GoTo clearError

    ' Source
    Const Extension As String = "xlsx"
    Const srcName As String = "sheetwithimage"
    Const srcList As String = "A1,A2,A3" ' add more
    Const picIndex As Long = 1
    ' Destination
    Const dstName As String = "Sheet1"
    Const dstList As String = "B1,B2,B3" ' add more
    Const picAddress As String = "B7"
    Const colOffset As Long = 5
    
    ' Write file paths from Source Folder Path to File Paths array.
    Dim wbDst As Workbook: Set wbDst = ThisWorkbook
    Dim srcFolderPath As String: srcFolderPath = wbDst.Path
    Dim FilePaths As Variant
    FilePaths = getFilePathsInFolder(srcFolderPath, Extension)
    
    
    Dim srcCells() As String: srcCells = Split(srcList, ",")
    Dim dstCells() As String: dstCells = Split(dstList, ",")
    ' Use a variable for lower and upper if inside another loop.
    ' Split ensures that lower is 0, so no need for lower variable.
    Dim CellsUB As Long: CellsUB = UBound(srcCells) ' or 'Ubound(dstCells)'
    Dim dst As Worksheet: Set dst = wbDst.Worksheets(dstName)
    Dim dstFilePath As String: dstFilePath = wbDst.FullName
    
    ' Declare new variables occurring in the following loop.
    Dim wbSrc As Workbook
    Dim src As Worksheet
    Dim srcCount As Long
    Dim fp As Long
    Dim n As Long
    
    Application.ScreenUpdating = False
    
    ' We don't care if 'FilePaths' is zero, one or five-based, since we
    ' cannot use fp because of 'ThisWorkbook'; hence 'srcCount'.
    For fp = LBound(FilePaths) To UBound(FilePaths)
        ' We have to skip 'ThisWorkbook'. Using 'StrComp' with 'vbTextCompare'
        ' is a great way for comparing strings case-insensitively i.e. 'A=a'.
        ' '0' means it is a match.
        If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then
            Set wbSrc = Workbooks.Open(FilePaths(fp), True, True)
            Set src = wbSrc.Worksheets(srcName)
            src.Pictures(picIndex).Copy
            dst.Range(picAddress).Offset(, srcCount * colOffset).PasteSpecial
            For n = 0 To CellsUB ' 'Split'
                dst.Range(dstCells(n)).Offset(, srcCount * colOffset).Value _
                    = src.Range(srcCells(n)).Value
            Next n
            wbSrc.Close SaveChanges:=False
            srcCount = srcCount + 1
        End If
    Next fp
    
    ' Save and/or inform user.
    If srcCount > 0 Then
        dst.Range("A1").Select
        wbDst.Save
        Application.ScreenUpdating = True
        If srcCount = 1 Then
            MsgBox "Data from 1 workbook transferred.", vbInformation, "Success"
        Else
            MsgBox "Data from " & srcCount & " workbooks transferred.", _
                vbInformation, "Success"
        End If
    Else
        MsgBox "No matching workbooks found in folder '" & srcFolderPath _
            & "'!", vbCritical, "Fail"
    End If

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
    
End Sub

Function getFilePathsInFolder( _
    FolderPath As String, _
    Optional ByVal ExtensionPattern As String = "", _
    Optional ByVal FirstIndex As Long = 0) _
As Variant
    
    Const ProcName As String = "listFilePathsInFolder"
    On Error GoTo clearError
    
    With CreateObject("Scripting.FileSystemObject")
        Dim fsoFolder As Object
        Set fsoFolder = .GetFolder(FolderPath)
        Dim FilesCount As Long
        FilesCount = fsoFolder.Files.Count
        If FilesCount > 0 Then
            Dim n As Long
            n = FirstIndex - 1
            Dim OneD As Variant
            ReDim OneD(FirstIndex To FilesCount + n)
            Dim fsoFile As Object
            If ExtensionPattern = "" Then
                For Each fsoFile In fsoFolder.Files
                    n = n + 1
                    OneD(n) = fsoFile.Path
                Next fsoFile
                getFilePathsInFolder = OneD
            Else
                For Each fsoFile In fsoFolder.Files
                    If LCase(.GetExtensionName(fsoFile)) _
                            Like LCase(ExtensionPattern) Then
                        n = n + 1
                        OneD(n) = fsoFile.Path
                    End If
                Next fsoFile
                If n > FirstIndex - 1 Then
                    ReDim Preserve OneD(FirstIndex To n)
                    getFilePathsInFolder = OneD
                Else
                    Debug.Print "'" & ProcName & "': " _
                        & "No '" & ExtensionPattern & "'-files found."
                End If
            End If
        Else
            Debug.Print "'" & ProcName & "': " _
                & "No files found."
        End If
    End With

ProcExit:
    Exit Function

clearError:
    Debug.Print "'" & ProcName & "': Unexpected error!" & vbLf _
        & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
        & "        " & Err.Description
    Resume ProcExit

End Function