Excel скопировать гиперссылку vba - Word и Excel - помощь в работе с программами

0 / 0 / 0

Регистрация: 15.01.2018

Сообщений: 8

Копирование гиперссылки в ВБА

15.01.2018, 18:10. Показов 4857. Ответов 13

Помогите ,пожалуйста.В одной таблице в каждой ячейке хранится гиперссылка на файл документа.
В другую таблицу необходимо к одной записи добавить в колонку гиперссылок — после уже записанного текста необходимо вставить список гиперссылок из 1 таблицы. Как скопировать именно гиперссылку, а не всю ячейку( когда копируешь ячейку,заменяется вся ячейка 2-таблицы,стирается текст)

Programming

Эксперт

94731 / 64177 / 26122

Регистрация: 12.04.2006

Сообщений: 116,782

15.01.2018, 18:10

Ответы с готовыми решениями:

Графики в ВБА
Нужно построить два графика в вба, на одном поле x3 и 5-x. Не получается нифига, даже код кидать…

Прикладное программирование ВБА
Помогите пожалуйста

При открытии своей книги,программным путём,формировать на листе2 заголовок…

Суммирование строк в вба
Как можно просуммировать строки матрицы согласно условию?

Увидеть код ВБА
здравствуйте, есть файл, который при открытии удаляет модуль с макросами, открыл его а код уже…

~~Остап Бонд~~

Заблокирован

15.01.2018, 18:15

olga_b, что есть и что надо — маленький пример в виде файла приложите…

0 / 0 / 0

Регистрация: 15.01.2018

Сообщений: 8

15.01.2018, 18:30

[ТС]

Вид табличек

1232 / 670 / 238

Регистрация: 22.12.2015

Сообщений: 2,089

15.01.2018, 19:52

olga_b, в общем-то — смысл искать решение на VBA? Если таблицу скопировать в Эксель, скопировать первый столбец и вставить поверх второго через ctrl+alt+v с опцией «только значения», текст гиперссылки сохраняется. Копируете в любое место в Word → преобразовать в текст, и получаете нужный вам список гиперссылок, копируете его в нужную ячейку.

0 / 0 / 0

Регистрация: 15.01.2018

Сообщений: 8

15.01.2018, 20:42

[ТС]

Смысл в том,что документ формируется из программы бизнес-студио, в котором много таблиц и текста, и эта одна из таблиц, в ячейку в которую нужно вставить список гиперссылок, пишутся данные из 4-таблиц. И когда это текст,то проблем не возникает,проблемы только с гиперссылками

1232 / 670 / 238

Регистрация: 22.12.2015

Сообщений: 2,089

15.01.2018, 20:47

Сообщение от olga_b

в ячейку в которую нужно вставить список гиперссылок, пишутся данные из 4-таблиц.

Ну и беда то в чем? Если с текстом проблем не возникает, то гиперссылки нужно копировать транзитом через эксель, на выходе будет текст из левой колонки с присвоенными этому тексту гиперссылками из правой.
У вас объемы большие, или таких файлов много, или в чем неудобство?
В файле есть еще гиперссылки, кроме как в этой таблице?

0 / 0 / 0

Регистрация: 15.01.2018

Сообщений: 8

15.01.2018, 21:51

[ТС]

Попробовала через єксель. Копируете в любое место в Word → преобразовать в текст, и получаете нужный вам список гиперссылок- получаю список названий гиперссылок ,а не сами ссылки. Мне нужно именно в конец ячейки таблицы вставить список из нескольких гиперссылок. Именно в этом проблема

Dinoxromniy

1232 / 670 / 238

Регистрация: 22.12.2015

Сообщений: 2,089

15.01.2018, 22:04

Сообщение от olga_b

получаю список названий гиперссылок ,а не сами ссылки

Ссылки были потеряны еще в экселе — проверьте.
Копировать столбик с текстом на столбик с гиперссылками нужно с опцией «только значения», гиперссылки должны работать еще в экселе.

Как вариант — можете использовать код ниже.
Оговорки:
1. Курсор перед началом работы нужно установить на таблицу с текстом и гиперссылками.
2. Таблица должна как в вашем примере состоять из двух столбцов, первая строка — заглавие. Пара «текст-гиперссылка» должна находиться на каждой строчке- как в вашем примере.

Visual Basic

Public Sub HipInsert()
Dim tblData As Table
Dim i As Integer
 Set tblData = Selection.Tables.Item(1)
 
Selection.EndKey Unit:=wdStory
For i = 2 To tblData.Rows.Count
    ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=tblData.Cell(i, 2).Range.Hyperlinks.Item(1).Address, SubAddress:="", ScreenTip:="", TextToDisplay:=Replace(tblData.Cell(i, 1).Range, Chr(13) & Chr(7), "")
    Selection.TypeParagraph
Next i
tblData.Cell(1, 1).Select
Selection.Collapse
Set tblData = Nothing
End Sub

0 / 0 / 0

Регистрация: 15.01.2018

Сообщений: 8

15.01.2018, 22:52

[ТС]

Вставляет мимо ячейки второй таблицы

Миниатюры

Dinoxromniy

1232 / 670 / 238

Регистрация: 22.12.2015

Сообщений: 2,089

15.01.2018, 23:18

Сообщение от olga_b

Вставляет мимо ячейки второй таблицы

Вставляет в конец документа, т.к. непонятно, где вторая таблица будет в реальном документе.
Если в вашем документе первая таблица всегда будет первой, а вторая — второй, а остальные таблицы — будут ниже первых двух, то код будет проще.

Visual Basic

Public Sub HipInsertTwoTables()
Dim tblData As Table, tblTarget As Table
Dim i As Integer
 Set tblData = ActiveDocument.Tables.Item(1)
Set tblTarget = ActiveDocument.Tables.Item(2)
tblTarget.Cell(1, 3).Range.Paragraphs.Item(tblTarget.Cell(1, 3).Range.Paragraphs.Count - 1).Range.Select
 Selection.Collapse wdCollapseEnd
For i = 2 To tblData.Rows.Count
    ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=tblData.Cell(i, 2).Range.Hyperlinks.Item(1).Address, SubAddress:="", ScreenTip:="", TextToDisplay:=Replace(tblData.Cell(i, 1).Range, Chr(13) & Chr(7), "")
    Selection.TypeParagraph
Next i
tblData.Cell(1, 1).Select
Selection.Collapse
Set tblData = Nothing
Set tblTarget = Nothing
End Sub

0 / 0 / 0

Регистрация: 15.01.2018

Сообщений: 8

15.01.2018, 23:29

[ТС]

Спасибо огромное, завтра на работе попробую на реальном документе. Должно уже получиться. У меня таблицы там по закладкам

Казанский

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

15.01.2018, 23:44

olga_b, может это поможет — макрос преобразует таблицу типа первой таблицы в документе в простой текст с гиперссылками. Перед запуском поставьте курсор в таблицу, которую надо преобразовать. После скопируйте абзацы и вставьте в нужное место.

Visual Basic

Sub bb()
Dim s$, c As Cell
  With Selection.Tables(1)
    For Each c In .Columns(2).Cells
      If c.Range.Hyperlinks.Count Then
        s = c.Previous.Range.Text
        c.Range.Hyperlinks(1).TextToDisplay = Trim$(Left$(s, Len(s) - 2))
      End If
    Next
    .Columns(1).Delete
    .ConvertToText
  End With
End Sub

1232 / 670 / 238

Регистрация: 22.12.2015

Сообщений: 2,089

16.01.2018, 00:03

Казанский, красиво.
c.Previous.Range — это ссылка на предыдущую ячейку таблицы Word относительно текущей?

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

16.01.2018, 00:20

Dinoxromniy, да. В Word VBA у многих объектов есть методы Previous и Next (F1 — Previous).
Позволяют не только сократить код, но и ускорить: Макрос на замену каждого третьего слова в тексте на код EQ

IT_Exp Эксперт 87844 / 49110 / 22898 Регистрация: 17.06.2006 Сообщений: 92,604	16.01.2018, 00:20
14

Источник

Всем доброго здоровья!
Собираю некоторые данные на в таблицу на листе. Делаю это через массивы, т.к. конечный результат буде примерно 30 столбцов и до 10 000 строк.
Но в каждой строке должна быть гиперссылка типа

Планета Excel

Перенести гиперссылку довольно легко обычным Copy, но тогда я не смогу работать массивом; придется все делать на листе — а это очень долго.
Вопрос: как скопировать гиперссылку через массив?
Или, как в VBA «прочитать» гиперссылку, т.е. получить отдельно текст и адрес?

Sanja

Пользователь

Сообщений: 14838
Регистрация: 10.01.2013

01.07.2017 12:29:48

Цитата
Михаил С. написал: как в VBA «прочитать» гиперссылку, т.е. получить отдельно текст и адрес?

Ну для одной ячейки можно так

Код
With Sheets(1).Range("B1").Hyperlinks(1) MsgBox "Адрес: " & .Address & vbCrLf & "Текст: " & .TextToDisplay End With

А вот как получить это в массив без перебора ячеек — вопрос..

Согласие есть продукт при полном непротивлении сторон.

	Sanja, спасибо, подумаю над этим вариантом. Перебрать оден столбец все таки быстрее, чем по ячейкам проходить два листа.

Sanja

Пользователь

Сообщений: 14838
Регистрация: 10.01.2013

01.07.2017 12:36:57

Почитал тут справку. И т.к. 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

Согласие есть продукт при полном непротивлении сторон.

Sanja

Пользователь

Сообщений: 14838
Регистрация: 10.01.2013

01.07.2017 13:59:59

Михаил, как-то так получилось. Не знаю, насколько быстро будет на больших объёмах

Код

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

Прикрепленные файлы

VBA копирование гиперссылки.xlsm (19.58 КБ)

Согласие есть продукт при полном непротивлении сторон.

	Sanja, Ок, спасибо, попробую.

RAN

Пользователь

Сообщений: 7091
Регистрация: 21.12.2012

01.07.2017 20:48:43

Немного поигрался. Количество гиперсылок — 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

Источник

Предположим, у меня есть список значений в столбце A, и каждая ячейка содержит другую гиперссылку, теперь я хочу скопировать только гиперссылки без текста в другой столбец E, как показано на следующем снимке экрана. Возможно, нет прямого способа решить эту задачу в Excel, но здесь я могу ввести код VBA для решения этой проблемы.

Скопируйте гиперссылку из одной ячейки в другую с кодом VBA

Скопируйте гиперссылку из одной ячейки в другую с кодом VBA

Чтобы скопировать только адреса гиперссылок без текста в другие ячейки, следующий код может оказать вам услугу, например:

1. Удерживайте ALT + F11 , чтобы открыть Microsoft Visual Basic для приложений окно.

2. Нажмите Вставить > Модулии вставьте следующий код в Модули Окно.

Код VBA: копировать гиперссылку только из одной ячейки в другую:

Sub CopyHyperlinks()
'Uodateby Extendoffice
    Dim xSRg As Range
    Dim xDRg As Range
    Dim I As Integer
    Dim xAddress As String
    On Error Resume Next
    xAddress = ActiveWindow.RangeSelection.Address
    Set xSRg = Application.InputBox("Please select the original range you want to copy hyperlinks:", "KuTools For Excel", xAddress, , , , , 8)
    If xSRg Is Nothing Then Exit Sub
    Set xDRg = Application.InputBox("Please select the new range you want to paste the hyperlinks only", "KuTools For Excel", , , , , , 8)
    If xDRg Is Nothing Then Exit Sub
    Set xDRg = xDRg(1)
    For I = 1 To xSRg.Count
        If xSRg(I) <> "" And xDRg.Offset(I - 1) <> "" Then
            If xSRg(I).Hyperlinks.Count = 1 Then
                xDRg(I).Hyperlinks.Add xDRg(I), xSRg(I).Hyperlinks(1).Address
            End If
        End If
    Next
End Sub

3, Затем нажмите F5 нажмите клавишу для запуска этого кода, появится диалоговое окно, напоминающее вам о выборе ячеек, в которые вы хотите скопировать только гиперссылки, см. снимок экрана:

4, Затем нажмите OK, затем выберите ячейки, в которые вы хотите вставить гиперссылки, только в другое диалоговое окно, см. снимок экрана:

5. И адреса гиперссылок были скопированы из исходных ячеек в указанные ячейки по мере необходимости, см. Снимок экрана:

Внимание: Этот код также может помочь вам скопировать гиперссылки с одного листа на другой по вашему желанию.

Лучшие инструменты для работы в офисе

Kutools for Excel Решит большинство ваших проблем и повысит вашу производительность на 80%

Снова использовать: Быстро вставить сложные формулы, диаграммы и все, что вы использовали раньше; Зашифровать ячейки с паролем; Создать список рассылки и отправлять электронные письма …
Бар Супер Формулы (легко редактировать несколько строк текста и формул); Макет для чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон…
Объединить ячейки / строки / столбцы без потери данных; Разделить содержимое ячеек; Объединить повторяющиеся строки / столбцы… Предотвращение дублирования ячеек; Сравнить диапазоны…
Выберите Дубликат или Уникальный Ряды; Выбрать пустые строки (все ячейки пустые); Супер находка и нечеткая находка во многих рабочих тетрадях; Случайный выбор …
Точная копия Несколько ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое …
Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов по страницам; Преобразование содержимого ячеек в комментарии…
Суперфильтр (сохранять и применять схемы фильтров к другим листам); Расширенная сортировка по месяцам / неделям / дням, периодичности и др .; Специальный фильтр жирным, курсивом …
Комбинируйте книги и рабочие листы; Объединить таблицы на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF…
Более 300 мощных функций. Поддерживает Office/Excel 2007-2021 и 365. Поддерживает все языки. Простое развертывание на вашем предприятии или в организации. Полнофункциональная 30-дневная бесплатная пробная версия. 60-дневная гарантия возврата денег.

Вкладка Office: интерфейс с вкладками в Office и упрощение работы

Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!

Комментарии (13)

Оценок пока нет. Оцените первым!

Источник

@tachyglossus

Extract actual addresses from hyperlinks with VBA code

Press on the heading to get more possibilities and options.

Hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window.

Click Insert> Module and paste the following code into the module window.

Sub Extracthyperlinks ()

‘Updateby Extendoffice

Dim Rng As Range

Dim WorkRng As Range

On Error Resume Next

xTitleId = «KutoolsforExcel»

Set WorkRng = Application.Selection

Set WorkRng = Application.InputBox («Range», xTitleId, WorkRng.Address, Type: =

For Each Rng In WorkRng

If Rng.Hyperlinks.Count> 0 Then

Rng.Value = Rng.Hyperlinks.Item (1) .Address

End If

End Sub

Then press F5 when you press the key to run the code, it will bring up a dialog box for you to choose the hyperlinks that you want to extract the actual addresses from.

Then click OK and the selected cell contents will be converted to the real hyperlink addresses in the original range.

Источник

Cell hyperlink = «https://windchill.com/Windchill/app/#ptc1/tcomp/infoPage?ContainerOid=OR%3Awt.pdmlink.PDMLinkProduct%dfasdfasdfasdf&oid=VR%3Awt.doc.WTDocument%»

Vba code:

Url = activecell.hyperlinks(1).address

Result:

Url = "https://windchill.com/Windchill/app/"

I need full hyperlink but I am getting result up to before #

How can I resolve this issue?

halfer

19.8k17 gold badges97 silver badges185 bronze badges

asked Mar 17, 2021 at 19:57

It splits the address in 2 properties for me and it needs to be rebuilt:

Url = activecell.hyperlinks(1).Address & "#" &activecell.hyperlinks(1).SubAddress

answered Mar 17, 2021 at 20:15

Dávid LaczkóDávid Laczkó

1,0692 gold badges6 silver badges22 bronze badges

Источник