Найти ячейки с определенным текстом и добавить гиперссылки в цикле

Question

tldr : Найти ячейки с номером детали xxxxx и добавить гиперссылку на чертеж на сервере.

У нас есть электронная таблица, содержащая номера деталей в нескольких столбцах и строках. Наше требование - добавить гиперссылку на чертеж деталей, хранящийся на нашем сервере. Мы попытались выделить их как группу, но получили ошибку

, этого нельзя сделать при множественном выборе диапазона

Мы также хотим сохранить информацию о комментариях без измененийПросто чтобы усложнить это дальше.

Есть ли код, который мы можем использовать для поиска part number xxxxx и добавления гиперссылки, затем найти следующую ячейку и повторить процесс?

Мы нашли код "найти все", который выделяетячейки, просто нужна помощь с проблемой гиперссылки.

Sub FindAll()

    Dim fnd As String, FirstFound As String
    Dim FoundCell As Range, rng As Range
    Dim myRange As Range, LastCell As Range

    'What value do you want to find (must be in string form)?
    fnd = "70005"

    Set myRange = ActiveSheet.UsedRange
    Set LastCell = myRange.Cells(myRange.Cells.Count)
    Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)

    'Test to see if anything was found
    If Not FoundCell Is Nothing Then
        FirstFound = FoundCell.Address
    Else
        GoTo NothingFound
    End If

    Set rng = FoundCell

    'Loop until cycled through all unique finds
    Do Until FoundCell Is Nothing
        'Find next cell with fnd value
        Set FoundCell = myRange.FindNext(after:=FoundCell)

        'Add found cell to rng range variable
        Set rng = Union(rng, FoundCell)

        'Test to see if cycled through to first found cell
        If FoundCell.Address = FirstFound Then Exit Do

    Loop

    'Select Cells Containing Find Value
    rng.Select

    Exit Sub

    'Error Handler
    NothingFound:
    MsgBox "No values were found in this worksheet"

End Sub

Answer 1

Ваш метод может быть немного упрощен. Я предлагаю создать функцию, которая добавит ваши гиперссылки в любую заданную область.

Мои тестовые данные

Option Explicit

Sub test()
    Dim linkCount As Long
    linkCount = AddHyperLinkTo(FindArea:=Sheet1.UsedRange, _
                               FindThis:="red", _
                               Link:="https://google.com")
    Debug.Print "found: " & linkCount
End Sub

Function AddHyperLinkTo(ByRef FindArea As Range, _
                        ByVal FindThis As Variant, _
                        ByVal Link As String) As Long

    Dim numberFound As Long
    Dim parentWS As Worksheet
    Set parentWS = FindArea.Parent

    Dim firstFind As Range
    Dim findResult As Range
    Set findResult = FindArea.Find(What:=FindThis, LookIn:=xlValues)
    Set firstFind = findResult
    Do Until findResult Is Nothing
        parentWS.Hyperlinks.Add Anchor:=findResult, Address:=Link
        numberFound = numberFound + 1
        Set findResult = FindArea.Find(What:=FindThis, LookIn:=xlValues, After:=findResult)
        If findResult.Address = firstFind.Address Then
            Exit Do
        End If
    Loop
    AddHyperLinkTo = numberFound
End Function