Страницы: 1
RSS
Как извлечь данные из файла по гиперссылка из ячейки
 
Есть файл(POS.xlsx), в нем в столбце "B" хранятся гиперссылки на другие файлы. Нужно в столбец "D" вывести значения из C2 тех файлов по гиперссылкам.
Pos.rar содержит POS.xlsx и файлы на которые ссылаются гиперссылки.
Изменено: Leshuy - 12.07.2019 02:07:16
 
ПРОСМОТРЕТЬ ВСЕ ФАЙЛЫ В ПАПКЕ
Скрытый текст
Согласие есть продукт при полном непротивлении сторон
 
Sanja, Ну в какие то другие дебри пошли. Проще же просто прописать формулу и в ней  ссылку на основании адреса гиперссылки. Единственное - это чуть повозится с релятивным имением файлов.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал: Проще же просто прописать формулу
А мы вот сейчас у ТС и узнаем что ему проще - на кнопку жмякнуть или
Цитата
БМВ написал: повозится с релятивным имением файлов
;)  
Согласие есть продукт при полном непротивлении сторон
 
Sanja,  ну я имел в виду жмакнуть на кнопку и по списку ссылок пробежаться и формул накалякать. Хотя может задача как раз из всех файлов получить в том числе и ссылки, а не ...
По вопросам из тем форума, личку не читаю.
 
Михаил, мое личное ИМХО, вставлять формулы макросом - это не наш метод, да и в чем сложность моих 'дебрей'?
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
в чем сложность моих 'дебрей'?
Ну для начала решение не совсем подходит под название темы :-) . В каталоге может быть не только файлы для обработки и наоборот, нужно обработать несколько каталогов....
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал: решение не совсем подходит
Ну так то мы обсуждаем только мое решение ;) . Других вообще больше нет
Согласие есть продукт при полном непротивлении сторон
 
Я в свой лимит 10 строк не могу уложится, из-за реляционности пути :-).

Код
Sub fillFormulas()
Dim Address As String, MyCell As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Sheet1
    For Each MyCell In Intersect(.Columns(2), .UsedRange)
     Address = Replace(MyCell.Hyperlinks(1).Address, "/", "\")
     MyCell.Offset(, 2).Formula = "='" & _
        IIf(InStr(Address, ":") < 1, ThisWorkbook.Path & Application.PathSeparator, "") & _
        Left(Address, InStrRev(Address, "\")) & "[" & Mid(Address, InStrRev(Address, "\") + 1, 256) & _
        "]" & "Check & Resolve Procedure'!$C$2"
    Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Изменено: БМВ - 12.07.2019 11:15:33
По вопросам из тем форума, личку не читаю.
 
Fso.GetAbsolutePathName
Владимир
 
sokol92, Владими, в ссылке может быть относительный путь, или прямой. В одном случае надо вставить путь текущей книги, а в другом оставить, я про это.
Изменено: БМВ - 12.07.2019 14:24:28
По вопросам из тем форума, личку не читаю.
 
Так и я о том же :) . Указанный в #10 метод всё переведет в абсолютный (прямой) путь. Естественно, перед вызовом в макросе нужно сменить (если необходимо) текущий путь в приложении на путь книги.
Владимир
 
Цитата
sokol92 написал:
Естественно, перед вызовом в макросе нужно сменить (если необходимо) текущий путь в приложении на путь книги
ну да и желательно вернуть обратно
Код
Sub fillFormulas()
Dim Address As String, MyCell As Range, CD As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
CD = CurDir
ChDir (ThisWorkbook.path)
With Sheet1
    For Each MyCell In Intersect(.Columns(2), .UsedRange)
     Address = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(MyCell.Hyperlinks(1).Address)
     MyCell.Offset(, 2).Formula = "='" & Left(Address, InStrRev(Address, "\")) & "[" & Mid(Address, InStrRev(Address, "\") + 1, 256) & "]" & "Check & Resolve Procedure'!$C$2"
    Next
End With
ChDir (CD)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал: В одном случае надо вставить путь текущей книги, а в другом оставить...и желательно вернуть обратно
Ну и у кого 'дебри'? :D Туда-сюда-обратно! Кручу-верчу, запутать хочу?
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Кручу-верчу, запутать хочу
это все Владимир искушает. В #9 все прямолинейно и почти 10 строк :-)
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
это все Владимир искушает
Имя болезни - перфекционизм (и не мы одни ей страдаем).  :)  
Изменено: sokol92 - 12.07.2019 15:54:40
Владимир
 
Всем огромное спасибо!
Цитата
ну я имел в виду жмакнуть на кнопку и по списку ссылок пробежаться и формул накалякать.
По сути да.

Цитата
Хотя может задача как раз из всех файлов получить в том числе и ссылки, а не ...
Ссылки уже есть в виде гиперссылок в столбце B

Код В 13#
Выдает ссылки на диск C почемуто.
Если запустить макрос на С, а потом переместить на D то ссылки сами трансформируются под новый путь.

Код В 9#
Отлично написано. Работает отлично.) Сейчас пытаюсь сделать чтоб по всем листам файла Pos сразу работало.
PS:
Итоговый код
Код
Sub fillFormulas()
Dim Address As String, MyCell As Range, I As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For I = 1 To Sheets.Count
With Sheets(I)
    For Each MyCell In Intersect(.Columns(2), .UsedRange)
     Address = Replace(MyCell.Hyperlinks(1).Address, "/", "\")
     MyCell.Offset(, 2).Formula = "='" & _
        IIf(InStr(Address, ":") < 1, ThisWorkbook.Path & Application.PathSeparator, "") & _
        Left(Address, InStrRev(Address, "\")) & "[" & Mid(Address, InStrRev(Address, "\") + 1, 256) & _
        "]" & "Check & Resolve Procedure'!$C$2"
        Next
    End With
Next I
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Всем еще раз Спасибо.  8)
Изменено: Leshuy - 12.07.2019 21:40:46
 
Столкнулся с ошибкой: "run time error 9"
Происходит при переносе в файл строк с гиперссылками.
Debug выдает:
 
Leshuy,
Ну gеребор листов лучше так, хотя это дело вкуса.
Код
Sub fillFormulas()
Dim Address As String, MyCell As Range, sh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each sh In Sheets
    With sh
        For Each MyCell In Intersect(.Columns(2), .UsedRange)
         Address = Replace(MyCell.Hyperlinks(1).Address, "/", "\")
         MyCell.Offset(, 2).Formula = "='" & _
            IIf(InStr(Address, ":") < 1, ThisWorkbook.Path & Application.PathSeparator, "") & _
            Left(Address, InStrRev(Address, "\")) & "[" & Mid(Address, InStrRev(Address, "\") + 1, 256) & _
            "]" & "Check & Resolve Procedure'!$C$2"
        Next
    End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


А вот для разбора ошибки нужен пример.
По вопросам из тем форума, личку не читаю.
 
Причина в ячейках без гиперссылки (если первая без ссылки то работает, остальные нет).
Может создать условие по типу: Если ссылка есть то вывод значения, если нет то пропуск...
Изменено: Leshuy - 13.07.2019 19:17:14
 
Для будущих читателей темы добавлю, что менять (и восстанавливать) текущий каталог проще всего с помощью свойства CurrentDirectory объекта WScript.Shell.
"Родные" конструкции VBA не поддерживают Unicode.
Владимир
 
А почему решение из #2 не подошло?
Согласие есть продукт при полном непротивлении сторон
 
sokol92,  Владимир, ту еще одна бяка будет, это работа не с конкретным драйвом, а с UNC. Ну понятно что я забыл сменить диск и вернуть его обратно, но похоже лучшее враг хорошему.
Leshuy,
Код
Sub fillFormulas()
Dim Address As String, MyCell As Range, sh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each sh In Sheets
    With sh
        For Each MyCell In Intersect(.Columns(2), .UsedRange)
            If MyCell.Hyperlinks.Count > 0 Then
                Address = Replace(MyCell.Hyperlinks(1).Address, "/", "\")
                MyCell.Offset(, 2).Formula = "='" & _
                IIf(InStr(Address, ":") < 1, ThisWorkbook.Path & Application.PathSeparator, "") & _
                Left(Address, InStrRev(Address, "\")) & "[" & Mid(Address, InStrRev(Address, "\") + 1, 256) & _
                "]" & "Check & Resolve Procedure'!$C$2"
            End If
        Next
    End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Надо ли очищать предварительно столбец D - вам решать.
Изменено: БМВ - 13.07.2019 20:42:01
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
это работа не с конкретным драйвом, а с UNC
Михаил, насколько я понимаю, при присвоении CurrentDirectory используется unicode версия API SetCurrentDirectoryW, так что будет работать со всеми методами задания директорий. По какой логике распределили оболочку над Win API между объектами FSO и Wscript.Shell мне не известно. Каждый раз подолгу ищу...
Владимир
 
БМВ Спасибо еще раз!
Работает.
Страницы: 1
Наверх