Страницы: 1
RSS
Изменения макроса, выводящего список файлов в папке, Необходимо видоизменить текст макроса
 
Добрый день.

Я совсем не силен в написании макросов, поэтому прошу помощи в следующем.
Есть отличный макрос https://www.planetaexcel.ru/techniques/3/45/. Как нужно переписать 51 строчку, чтобы гиперссылка открывала файл, а значение ячейки выводилось как название файла.
Заранее благодарю за помощь.
 
xottabuch, я тоже не силен в макросах но знаком с данным и он выводит название файла согласно названию файла в папке..а что вы хотите что то не понятно. Навернео понял вы хотите что бы путь стал ссылкой нажав по которой открылся файл, но высвечивалась не путь а корокто было написано название открываемого файла?!
Цитата

Если захотите, чтобы вместо пути к файлу в столбце B выводилась живая гиперссылка, то замените 52-ю строку

Cells(r, 2).Formula = FileItem.Path

на

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

Изменено: a.i.mershik - 18.09.2018 15:34:03
Не бойтесь совершенства. Вам его не достичь.
 
Есть столбец 1. В нем название файла. Хотелось бы чтобы в первом столбце значение ячейки осталось названием файла. Но при этом добавить гиперссылку на этот файл.
 
То есть я хочу чтобы имя файла в первой ячейке стало гиперссылкой на файл.
Совместить данные первого столбца и функциональность второго.
 
Скрытый текст
xottabuch
, ТАк?
Цитата
Sub FileList()
   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)
   
   'добавляем лист и выводим на него шапку таблицы
   ActiveWorkbook.Sheets.Add
   With Range("A1:E1")
       .Font.Bold = True
       .Font.Size = 12
   End With
   Range("A1").Value = "Имя файла"
   Range("B1").Value = "Путь"
   Range("C1").Value = "Размер"
   Range("D1").Value = "Дата создания"
   Range("E1").Value = "Дата изменения"
   
   'вызываем процедуру вывода списка файлов
   'измените 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

   Set FSO = CreateObject("Scripting.FileSystemObject")
   Set SourceFolder = FSO.getfolder(SourceFolderName)

   r = Range("A65536").End(xlUp).Row + 1   'находим первую пустую строку
   'выводим данные по файлу
   For Each FileItem In SourceFolder.Files
       Cells(r, 1).Formula = FileItem.Name
       Cells(r, 1).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & FileItem.Name & """ )"
       Cells(r, 2).Formula = FileItem.Path
       Cells(r, 3).Formula = FileItem.Size
       Cells(r, 4).Formula = FileItem.DateCreated
       Cells(r, 5).Formula = FileItem.DateLastModified
       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

   Columns("A:E").AutoFit

   Set FileItem = Nothing
   Set SourceFolder = Nothing
   Set FSO = Nothing

End Sub
Не знаю как оформить как маакрос)
Изменено: a.i.mershik - 18.09.2018 15:53:42
Не бойтесь совершенства. Вам его не достичь.
 
ДА! Спасибо огромное за помощь.
 
Код
Cells(r, 1).Hyperlinks.Add Anchor:=Cells(r, 1), Address:=FileItem.Path, TextToDisplay:=FileItem.Name
или даже
Код
Cells.Hyperlinks.Add Anchor:=Cells(r, 1), Address:=FileItem.Path, TextToDisplay:=FileItem.Name
По вопросам из тем форума, личку не читаю.
 
Цитата
a.i.mershik написал:
ТАк?
Спасибо большое. Интересный код. Беру на вооружение.

И дополнение БМВ то-же!
Изменено: pitby - 18.09.2018 16:58:36
Страницы: 1
Наверх