Здравствуйте. Нашел на этом сайте вот такой макрос ссылка Вставил в свой файл но он почему то не работает
Код
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
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", а если его выполнить ниже этой ячейки когда на нее переходишь выходит сообщение "не удается открыть указанный файл". Как быть?
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")
Чтобы можно было работать с любой ячейкой, где есть ссылка на файл
Не лучше попробовать переделать/переработать эти предыдущие (первые) макросы ? Зачем '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