Sub Впримечание()
    Dim V As String
    Dim BrowseFolder As String
     
    'открываем диалоговое окно выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку или диск"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "Вы ничего не выбрали!"
            Exit Sub
        End If
    End With
    
    
    BrowseFolder = CStr(V)
     
    'вызываем процедуру вывода списка файлов
    'измените True на False, если не нужно выводить файлы из вложенных папок
    ListFilesInFolder BrowseFolder, True
End Sub
 
 
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
 
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long
    Dim s As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.getfolder(SourceFolderName)


    r = Selection.Row   'находим первую пустую строку
    s = Selection.Column
    'выводим данные по файлу
    For Each FileItem In SourceFolder.Files

        Cells(r, s).Formula = "=HYPERLINK(""" & FileItem.Path & """)"

        r = r + 1
        X = SourceFolder.Path
        
    Next FileItem
     
    'вызываем процедуру повторно для каждой вложенной папки
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
 
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    
    Selection.End(xlUp).Select
    Selection.End(xlDown).Select
    Range(Selection, Selection.End(xlDown)).Select
       
 
'создаем примечания
 
    Dim rngPics As Range, rngOut As Range
    Dim i As Long, p As String, w As Long, h As Long
     
    Set rngPics = Selection.Rows    'диапазон путей к картинкам
    Set rngOut = Selection.Rows     'диапазон вывода примечаний
     
    rngOut.ClearComments        'удаляем старые примечания
     
    'проходим в цикле по ячейкам
    For i = 1 To rngPics.Cells.Count
     
        p = rngPics.Cells(i, 1).Value       'считываем путь к файлу картинки
        w = LoadPicture(p).Width            'и ее размеры
        h = LoadPicture(p).Height
         
        With rngOut.Cells(i, 1)
            .AddComment.Text Text:=""       'создаем примечание без текста
            .Comment.Visible = True
            .Comment.Shape.Select True
        End With
        With rngOut.Cells(i, 1).Comment.Shape   'заливаем картинкой
            .Fill.UserPicture p
            .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
            .ScaleHeight h / w * 1.8, msoFalse, msoScaleFromTopLeft     'корректируем размеры
        End With
    Next i
 
    Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    
 
End Sub

Sub PP()
Dim i, j As Integer
СтартоваяПапка = CreateObject("WScript.Shell").SpecialFolders("Desktop")
ПутьКПапке = GetFolderPath("Выберите папку на рабочем столе", СтартоваяПапка)
If ПутьКПапке = "" Then Exit Sub
ChDir ПутьКПапке
For i = 1 To Selection.Rows.Count
Open Selection(i, 1) & ".txt" For Output As #1
For j = 2 To Selection.Columns.Count
Print #1, Selection(i, j)
Next j
Close #1
Next i
MsgBox "Данные экспортированы"
End Sub
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
              Optional ByVal InitialPath As String = "c:\") As String
   Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
     If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
     .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
     If .Show <> -1 Then Exit Function
     GetFolderPath = .SelectedItems(1)
     If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

Sub DD()
Dim i As Integer
СтартоваяПапка = CreateObject("WScript.Shell").SpecialFolders("Desktop")
ПутьКПапке = GetFolderPath("Выберите папку на рабочем столе", СтартоваяПапка)
If ПутьКПапке = "" Then Exit Sub
ChDir ПутьКПапке
For i = 1 To Selection.Rows.Count
Open Selection(i, 1) & ".txt" For Output As #1
Print #1, Selection(i, 2)
Close #1
Next i
End Sub
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
              Optional ByVal InitialPath As String = "c:\") As String
   Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
     If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
     .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
     If .Show <> -1 Then Exit Function
     GetFolderPath = .SelectedItems(1)
     If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function