Всем доброго здоровья! Собираю некоторые данные на в таблицу на листе. Делаю это через массивы, т.к. конечный результат буде примерно 30 столбцов и до 10 000 строк. Но в каждой строке должна быть гиперссылка типа Планета Excel Перенести гиперссылку довольно легко обычным Copy, но тогда я не смогу работать массивом; придется все делать на листе - а это очень долго. Вопрос: как скопировать гиперссылку через массив? Или, как в VBA "прочитать" гиперссылку, т.е. получить отдельно текст и адрес?
Почитал тут справку. И т.к. 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
Михаил, как-то так получилось. Не знаю, насколько быстро будет на больших объёмах
Код
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
Немного поигрался. Количество гиперсылок - 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 минут пишет