Sub ReadFromFiles()'получение свойств файлов из выбранной папки и запись на лист
    Dim strFolder$, arr() As Variant, i&, r As ListRow, c As Range
    strFolder = SelectFolder()
    If strFolder = "" Then Exit Sub
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0
        Dim strFile$
        With CreateObject("DSOFile.OleDocumentProperties")
            strFile = Dir$(strFolder & "\*.jpg*")
            Do While Len(strFile)
                ReDim Preserve arr(5, i)
                arr(0, i) = strFile
                .Open strFolder & "\" & strFile, , 2
                Set ss = .SummaryProperties
                With .SummaryProperties
                    arr(2, i) = .Title
                    arr(3, i) = .Subject
                    arr(4, i) = .Keywords
                    arr(5, i) = .Comments
                End With
                .Close
                strFile = Dir$
                i = i + 1
            Loop
        End With
        With [Таблица1].ListObject
            .ListRows.Add 1
            .DataBodyRange.Delete
            .HeaderRowRange(2, 1).Resize(i, 6) = Application.Transpose(arr)
            For Each r In .ListRows
                Dim sd As ListRow
                Set c = r.Range(, 2)
                c.RowHeight = 60
                With ActiveSheet.Pictures.Insert(strFolder & "\" & c.Offset(, -1))
                    If .Width / .Height * c.RowHeight > c.Width - 2 Then
                        .Width = c.Width - 3
                    Else: .Height = c.RowHeight - 3
                    End If
                    .Top = c.Top + (c.Height - .Height) / 2
                    .Left = c.Left + (c.Width - .Width) / 2
                    .Placement = xlMoveAndSize
                End With
            Next
        End With
        .ScreenUpdating = 1: .EnableEvents = 1
    End With
End Sub
Sub Write2Files()'замена свойств файлов значениями с листа
    Dim strFolder$, r As ListRow
    strFolder = SelectFolder()
    If strFolder = "" Then Exit Sub
    With CreateObject("DSOFile.OleDocumentProperties")
        For Each r In [Таблица1].ListObject.ListRows
            .Open strFolder & "\" & r.Range(, 1), , 2
            With .SummaryProperties
                .Title = r.Range(, 7)
                .Subject = r.Range(, 8)
                .Keywords = r.Range(, 9)
                .Comments = r.Range(, 10)
            End With
            .Save: .Close
        Next
    End With
End Sub
Private Function SelectFolder$()
    With Application.FileDialog(msoFileDialogFolderPicker)
r:      If .Show Then
            SelectFolder = .SelectedItems(1)
        ElseIf MsgBox("Ничего не выбрано. Повторить?", 36, "Ну так как?") = 6 Then
            GoTo r
        Else: Exit Function
        End If
    End With
End Function