Excel — папки из ячеек с гиперссылками
В рамках одной из задач понадобилось создать папки с именами позиций заведенных в эксельку. Так как набралось больше сотни строк, да и в дальнейшем список грозит расширятся выполним эту задачу с помощью скрипта. Заодно добавим гиперссылок так, чтобы к каждой позиции у нас был доступ прямо из Эксель.
На выходе получаем список папок в экселе с со ссылками чтобы можно было их, папки, сразу открыть.
Код:
Sub Create_Folders()
'для корректной работы необходимо выбрать ячейки перед тем как запустить макрос.
Dim OpenAt As String 'Зададим каталог для папок по умолчанию.
OpenAt = "My computer:\"
'Вызовем диалог для выбора места папок.
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please Choose The Folder For This Project", 0, OpenAt)
'Устанавливаем выбранную папку в качестве рабочей. (в случае ошибки отменяем процесс)
On Error Resume Next
BrowseForFolder = ShellApp.Self.Path
'Выхватываем список выбранных ячеек.
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
'---в цикле проходим все ячейки в нашем---
For c = 1 To maxCols
r = 1
Do While r <= maxRows
'Если в ячейке есть какой то значение то создаем папку с этим знчением
If Rng(r, c) <> "" Then
'а на ячейку накидываем гиперссылку на папку с этим именем.
Dim cnf
Set cnf = CreateObject("Scripting.FileSystemObject")
'Если папка с таким именем по нашему пути уже существует, то просто добавляем гиперссылку.
If (cnf.FolderExists(BrowseForFolder & "\" & Rng(r, c))) Then
'MsgBox "folder does already exist"
ActiveSheet.Hyperlinks.Add Anchor:=Rng(r, c), Address:=BrowseForFolder & "\" & Rng(r, c)
'if folder does not previously exist, then we need to create it and add hyperlink
Else
'Сообщение "need to create folder"
cnf.CreateFolder (BrowseForFolder & "\" & Rng(r, c))
ActiveSheet.Hyperlinks.Add Anchor:=Rng(r, c), Address:=BrowseForFolder & "\" & Rng(r, c)
End If
On Error Resume Next
'если в ячейке пусто то ничего не делаем, идем на следующую ячейку
End If
r = r + 1
Loop
Next c
End Sub
Оригинальный скрипт взят отсюда.
http://excelspreadsheetshelp.blogspot.ru/2016/05/how-to-create-folders-with-hyperlink.html
Добавить комментарий