Страницы: 1
RSS
Скачать файл по нескольким гиперссылкам
 
Коллеги, добрый день. Прошу помочь в таком вопросе, написал макрос который скачивает файлы или папки по гиперссылке из активной ячейке по указанному пути. Однако, хотел бы его модернизировать, чтобы скачивались файлы и папки по всем выделенным ячейкам. Прошу помочь с данным вопросом. Файл пример и код прилагаю.

Код
Sub СохранениеПапки()
URL = FormulaHyperlink(ActiveCell) 'превращаю формульные гиперссылки в обычные
iSource = URL
For Each URL In ActiveCell
Next URL
  With Application.FileDialog(msoFileDialogFolderPicker)
 .Title = "Выбрать папку для сохранения"
 .ButtonName = "Выбрать папку"
 .Filters.Clear
 If .Show = 0 Then Exit Sub
 iDestination = .SelectedItems(1)
 End With
On Error GoTo ErrHandler
With CreateObject("Scripting.FileSystemObject")
 If .FolderExists(iSource) = True Then
 .CopyFolder iSource, iDestination ', True
 Else
 MsgBox "Копирование невозможно, нет папки", , ""
 End If
End With
ErrHandler:
If Err.Number <> 0 Then
 MsgBox Err.Description, vbCritical, ""
End If
End Sub


И функция для работы этого макроса
Код
Function FormulaHyperlink(ByRef cell As Range) As String
    If cell.HasFormula And (cell.Hyperlinks.Count = 0) Then
        If cell.Formula Like "=HYPERLINK*" Then
            FormulaHyperlink = Evaluate(Mid$(Split(cell.Formula, ",")(0), 12))
        End If
    End If
End Function
Изменено: stsergey - 07.04.2020 11:08:12
 
Коллеги, есть мысли? Такое вообще возможно?
Изменено: stsergey - 07.04.2020 11:08:39
 
Попробуйте так:
Код
Sub СохранениеПапки()
    Dim rc As Range
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выбрать папку для сохранения"
        .ButtonName = "Выбрать папку"
        .Filters.Clear
        If .Show = 0 Then Exit Sub
        iDestination = .SelectedItems(1)
    End With
    On Error GoTo ErrHandler
    With CreateObject("Scripting.FileSystemObject")
        For Each rc In Selection.Cells
            URL = FormulaHyperlink(rc) 'превращаю формульные гиперссылки в обычные
            iSource = URL
            If .FolderExists(iSource) Then
                .CopyFolder iSource, iDestination ', True
            End If
        Next
    End With
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbCritical, ""
    End If
End Sub
Function FormulaHyperlink(ByRef cell As Range) As String
    If cell.HasFormula And (cell.Hyperlinks.Count = 0) Then
        If cell.Formula Like "=HYPERLINK*" Then
            FormulaHyperlink = Evaluate(Mid$(Split(cell.Formula, ",")(0), 12))
        End If
    End If
End Function
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий, спасибо большое, реально работает!
 
А можете мне помочь. Такая же проблема только код предлагает выбрать папку, но туда ничего не скидывает.
Изменено: Анатолий Никоноров - 05.05.2023 16:35:51
Страницы: 1
Наверх