Страницы: 1
RSS
Копирование гиперссылки через массив, С сохранением "кликабельности"
 
Всем доброго здоровья!
Собираю некоторые данные на в таблицу на листе. Делаю это через массивы, т.к. конечный результат буде примерно 30 столбцов и до 10 000 строк.
Но в каждой строке должна быть гиперссылка типа Планета Excel
Перенести гиперссылку довольно легко обычным Copy, но тогда я не смогу работать массивом; придется все делать на листе - а это очень долго.
Вопрос: как скопировать гиперссылку через массив?
Или, как в VBA "прочитать" гиперссылку, т.е. получить отдельно текст и адрес?
 
Цитата
Михаил С. написал:
как в VBA "прочитать" гиперссылку, т.е. получить отдельно текст и адрес?
Ну для одной ячейки можно так
Код
    With Sheets(1).Range("B1").Hyperlinks(1)
        MsgBox "Адрес: " & .Address & vbCrLf & "Текст: " & .TextToDisplay
    End With
А вот как получить это в массив без перебора ячеек - вопрос..
Согласие есть продукт при полном непротивлении сторон
 
Sanja, спасибо, подумаю над этим вариантом.
Перебрать оден столбец все таки быстрее, чем по ячейкам проходить два листа.
 
Почитал тут справку. И т.к. HyperLinks это КОЛЛЕКЦИЯ, то с ней можно работать отдельно от ячеек. Например так
Код
    With Sheets(1)
        Arr1 = .Range("A1:A3").Value
        ReDim Arr2(.Range("B1:B3").Hyperlinks.Count-1)
        For Each hl In .Range("B1:B3").Hyperlinks
            Arr2(I) = hl.Address
            I = I + 1
        Next
    End With
Изменено: Sanja - 01.07.2017 12:42:45
Согласие есть продукт при полном непротивлении сторон
 
Михаил, как-то так получилось. Не знаю, насколько быстро будет на больших объёмах
Код
Sub HiperCopy()
Dim hlRange As Range
Dim Arr(), I&, lRow&
Dim hl As Hyperlink
With Sheets(1)
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    ReDim Arr(0 To 3, 0 To .Range("B1:B" & lRow).Hyperlinks.Count - 1)
    For Each hl In .Range("B1:B" & lRow).Hyperlinks
        Arr(0, I) = hl.Parent.Offset(, -1).Value
        Arr(1, I) = hl.TextToDisplay
        Arr(2, I) = hl.Parent.Address
        Arr(3, I) = hl.Address
        I = I + 1
    Next
End With
I = 0
With Sheets(2)
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A1:A" & lRow).Resize(UBound(Arr, 2) + 1, 1) = Application.Transpose(Arr)
    For I = 0 To UBound(Arr, 2)
        .Range(Arr(2, I)).Hyperlinks.Add Anchor:=.Range(Arr(2, I)), Address:=Arr(3, I), TextToDisplay:=Arr(1, I)
    Next
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Sanja, Ок, спасибо, попробую.
 
Немного поигрался. Количество гиперсылок - max возможное (65530 шт).
Код
Sub qq()
    Dim t!
    t = Timer
    With Worksheets(3)
        For I = 1 To 65530
            .Hyperlinks.Add .Cells(I, 1), "http://example.microsoft.com"
        Next
    End With
    Debug.Print Format(Timer - t, "0.0000")
End Sub

отрабатывает 40-50сек
Код
Sub q()
    Dim ar
    Dim t!
    t = Timer
    With Worksheets(3)
        ar = .Range("a1:a65530").Value
        ReDim Preserve ar(1 To UBound(ar), 1 To 2)
        For I = 1 To UBound(ar)
            ar(I, 2) = .Cells(I, 1).Hyperlinks(1).Address
            If I Mod 1000 Then DoEvents
        Next
        Debug.Print Format(Timer - t, "0.0000")
        .Range("a1:a65530").Clear
        .Cells(I, 3).Resize(UBound(ar)) = ar
        For I = 1 To UBound(ar)
            .Hyperlinks.Add .Cells(I, 3), ar(I, 2)
            If I Mod 1000 Then DoEvents
        Next
    End With
    Debug.Print Format(Timer - t, "0.0000")
End Sub

1,5 минуты читает, 1,5 минуты пишет
Код Sanja,  из #5 4 сек читает, 6 минут пишет
Изменено: RAN - 01.07.2017 20:49:12
Страницы: 1
Наверх