Страницы: 1
RSS
Гиперссылка со значением из текста поменять на название файла
 
Здравствуйте. Нашел на этом сайте вот такой макрос ссылка
Вставил в свой файл но он почему то не работает
Код
Sub MakeHyper() 'http://www.planetaexcel.ru/forum.php?thread_id=42349  
Dim LastRow As Long, i As Long, Adr As String, Str As String  
LastRow = Cells(Rows.Count, 2).End(xlUp).Row  
   For i = 2 To LastRow  
       Adr = Cells(i, 2).Value  
       Str = Split(Split(Cells(i, 2), "\")(UBound(Split(Cells(i, 2), "\"))), ".")(0)  
       Cells(i, 2).Hyperlinks.Add Anchor:=Cells(i, 2), Address:=Adr, TextToDisplay:=Str  
   Next  
End Sub
 
2 в Cells(Rows.Count, 2), Cells(i, 2), и т.д. измените на "A" или 1
Str As String (и другие Str) измените на Strg As String / Strg
For i = 2 измените на For i = 1
Изменено: ocet p - 09.01.2020 06:04:30
 
Спасибо за ответ. Но вот такая проблема, получается этот макрос, если первые ячейки столбца "A", пустые то макрос выдает ошибку:
Код
Strg = Split(Split(Cells(i, 1), "\")(UBound(Split(Cells(i, 1), "\"))), ".")(0)
Вот макрос:
Код
Sub ГиперссылкаПереименПоНазвФайлаСтолбецA()
Dim LastRow As Long, i As Long, Adr As String, Strg As String
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
   For i = 1 To LastRow
       Adr = Cells(i, 1).Value
       Strg = Split(Split(Cells(i, 1), "\")(UBound(Split(Cells(i, 1), "\"))), ".")(0)
       Cells(i, 1).Hyperlinks.Add anchor:=Cells(i, 1), Address:=Adr, TextToDisplay:=Strg
   Next
End Sub
И еще один момент:
Код
Sub ГиперссылкаПереименПоНазвФайла()
Dim LastRow As Long, i As Long, Adr As String, Strg As String
LastRow = ActiveCell.End(xlUp).Row
   For i = 1 To LastRow
       Adr = ActiveCell.Value
       Strg = Split(Split(ActiveCell, "\")(UBound(Split(ActiveCell, "\"))), ".")(0)
       ActiveCell.Hyperlinks.Add anchor:=ActiveCell, Address:=Adr, TextToDisplay:=Strg
   Next
End Sub
Этот макрос, не много переделал, он делает то же самое только с активной ячейкой. Но почему то в столбце "A", когда он макрос выполняет свое действие с ячейкой, потом на нее переходишь выходит сообщение "не удается открыть указанный файл", то же самое в столбце "E", только он работает до ячейки E7", а если его выполнить ниже этой ячейки когда на нее переходишь выходит сообщение "не удается открыть указанный файл". Как быть?
 
1 Добавьте проверку, что ячейка не пустая
If Len(Cells(i, 1)) Then

2
Цитата
Voltz написал:
выходит сообщение "не удается открыть указанный файл"
Я вот создал в корне диска С файл Рабочий.xlsm, и у меня файл открывается, а не сообщение, что файла нет.
 
А Вы с моего файла запускали макрос?
 
Voltz, свои сообщения можно редактировать.
 
Ну вот я смастерил такой макрос.
Код
Sub Макрос4()
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Range("A1"), TextToDisplay:=CStr([A2])
    Selection.Cut
    Range("A1").Select
    ActiveSheet.Paste
    Range("A2").Select
    Selection.ClearContents
    Range("A1").Select  
End Sub
Как мне в него вставить вот такую формулу "=СЖПРОБЕЛЫ(ПРАВБ(ПОДСТАВИТЬ(A2;"\";ПОВТОР(" ";50));50))", но чтобы в ней были относительные ссылки и на вот это тоже чтобы были относительные ссылки
Код
Address:=Range("A1")
Чтобы можно было работать с любой ячейкой, где есть ссылка на файл
 
Сократил его
Код
Sub Макрос1()
    ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:=ActiveCell, TextToDisplay:=CStr([A2])
 End Sub
Подскажите как сделать чтобы в ячейке прописывался не весь путь а только название файла и расширение?
 
Получилось! Только загвоздка помогите соединить, эти два макроса в один:
№1
Код
Sub Макрос1()
    ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:=ActiveCell
 End Sub
№2 он запускает сначала первый потом себя
Код
Sub Макрос2()
    ActiveCell.Select
    Application.Run "'4445.xlsm'!Макрос1"
    ActiveCell.Range("A1,EH1").Select
    ActiveCell.Offset(0, 137).Range("A1").Activate
    Selection.Replace What:="*\", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    ActiveCell.Offset(0, -137).Range("A1").Select
End Sub
Если можно, то только не такие варианты
Код
Sub Макрос3()
    Call Макрос1
    Call Макрос2
End Sub
А чтобы он просто был в одном
Изменено: Voltz - 10.01.2020 02:41:40
 
Код
Sub Макрос1()
   ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:=ActiveCell
   Макрос2
End Sub

 
Выдает ошибку
Код
ActiveCell.Range("A1,EH1").Select
 
Не лучше попробовать переделать/переработать эти предыдущие (первые) макросы ?
Зачем 'Select', 'ActiveCell', и т.д. ?
Например:
Код
Option Explicit

Sub MakeHyper()
    Dim i As Long, LastRow As Long, Adr As String, Strg
    Dim Bekslashina As Boolean, Dirovskiy As Boolean, Dotov As Boolean
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To LastRow
        Adr = Application.Trim(Cells(i, "A").Value)
        If Adr <> "" Then
            Bekslashina = CBool(InStr(1, Adr, "\", 1))
            Dirovskiy = CBool(Len(Dir(Adr, vbNormal)))
            Dotov = Len(Adr) - InStrRev(Adr, ".", -1, 1) = 4 'Dlya tipa: *.xlsx, *.xlsm
            If Bekslashina And Dirovskiy And Dotov Then
                Strg = Split(Adr, "\"): Strg = Split(Strg(UBound(Strg)), ".")(0)
                Cells(i, "A").Hyperlinks.Add Anchor:=Cells(i, "A"), Address:=Adr, TextToDisplay:=Strg
            End If
        End If
    Next
End Sub

Sub repyHekaM()
    Dim i As Long, LastRow As Long, Adr As String
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    On Error Resume Next
    For i = LastRow To 1 Step -1
        With Cells(i, "A")
            If Application.Trim(.Value) <> "" Then
                Adr = .Hyperlinks(1).Address:
                If Err.Number = 0 Then .Hyperlinks(1).Delete: .Value = Adr Else Err.Clear
            End If
        End With
    Next
End Sub

Sub MakerepyH()
    Dim i As Long, LastRow As Long, Strg
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row: Strg = LastRow \ 2
    On Error Resume Next '???
    For i = Strg To 1 Step -1 ' ... :) ...
        With ThisWorkbook.ActiveSheet.Cells(i, "A")
            If Application.Trim(.Value) <> "" Then .Hyperlinks(1).Follow
        End With
    Next
    For i = Strg + 1 To LastRow ' ... :) ...
        With ThisWorkbook.ActiveSheet.Cells(i, "A")
            If Application.Trim(.Value) <> "" Then .Hyperlinks(1).Follow
        End With
    Next
'    For i = 1 To LastRow
'        With ThisWorkbook.ActiveSheet.Cells(i, "A")
'            If Application.Trim(.Value) <> "" Then .Hyperlinks(1).Follow
'        End With
'    Next
End Sub
Изменено: ocet p - 13.01.2020 00:56:28
Страницы: 1
Наверх