Sub xx()
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = False
        Open ActiveWorkbook.Path & "\1.txt" For Input As #1
        With GetObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            .SetText Input$(LOF(1), 1)
            .PutInClipboard
        End With
        Close #1
        With [A2]
            Range(.Cells, .End(xlDown)).ClearContents
            .Cells(1).PasteSpecial xlPasteAll
            .Copy
        End With
        .CutCopyMode = 0
        .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1
    End With
End Sub

Sub Выбрать_картинку()

    Dim colFolders As New Collection, colFiles As New Collection
    Dim lngRnd As Long, i As Long
    
    Call GetFolders(ThisWorkbook.Path & "\Картинки", colFolders)
    
    For i = 1 To colFolders.Count
        Call GetFiles(colFolders(i), colFiles)
    Next i
    
    Randomize
    lngRnd = Int((colFiles.Count - 1 + 1) * Rnd + 1)
    ActiveSheet.Image1.Picture = LoadPicture(colFiles(lngRnd))

End Sub

Private Sub GetFolders(strParentFolder As String, colFolders As Collection)
    
    Dim strFolderName As String
    Dim col As New Collection, i As Long
    
    strFolderName = Dir(strParentFolder & "\", vbDirectory)
    Do While strFolderName <> ""
        If (GetAttr(strParentFolder & "\" & strFolderName) And vbDirectory) <> 0 Then
            If strFolderName <> "." And strFolderName <> ".." Then
                col.Add Item:=strParentFolder & "\" & strFolderName
            End If
        End If
        strFolderName = Dir
    Loop
    
    For i = 1 To col.Count
        colFolders.Add Item:=col(i)
    Next i
    
    For i = 1 To col.Count
        Call GetFolders(col(i), colFolders)
    Next i

End Sub

Private Sub GetFiles(strFolderName As String, colFiles As Collection)
    Dim strFileName As String
    strFileName = Dir(strFolderName & "\")
    Do While strFileName <> ""
        colFiles.Add Item:=strFolderName & "\" & strFileName
        strFileName = Dir
    Loop
End Sub

Sub Макрос1()
    Dim fr As Frame
    For Each fr In ThisDocument.Frames
        fr.Delete
    Next fr
End Sub