Find celler og indsæt hyperlinks med Excel VBA makroer

På denne side viser jeg, hvordan en makro automatisk kan finde celler med en given tekst eller værdi og dernæst indsætte hyperlinks til disse celler.

Eksemplet udspringer af en læserhenvendelse. Han havde et regneark med en masse faneblade og så et "oversigtsark" med nøgledata fra de andre faneblade. I stedet for at bruge Excels søgefunktion ville han gerne kunne skrive en tekst i en celle og så køre en makro, der fandt celler med samme tekst og indsatte hyperlinks til disse celler.

Det er nedenstående et eksempel på. Du kan også downloade en zip-komprimeret demoversion af regnearket. Eksemplet benytter sig af, at hvert faneblad har en Worksheet_Change procedure, som kan fange, når der sker noget med en celle.

Når brugeren skriver noget i en celle på oversigtsarket, gemmes cellen som en global rangevariabel, og når brugeren så kører makroen "FindDubletter," gennemsøges alle faneblade undtaget oversigtsarket for celler med samme indhold.

Hvis der er en eller flere dubletter, skal brugeren angive (klikke), hvor hyperlinksene skal indsættes. Eksemplet forudsætter, at der er et faneblad, som er navngivet "Oversigtsark".

Trin 1:

Hvert faneblad i et Excel-regneark har et tilhørende VBA kodeark, og her kan man lægge nogle standardprocedurer, som kaldes automatisk ved bestemte hændelser på fanebladet.

Vi benytter os af Worksheet_Change proceduren, som kører automatisk, når en celle eller et område på fanebladet ændres.

Åbn Excels VBA-editor (ALT+F11) og dobbeltklik på oversigtsarkets tilhørende kodeark. Hvis du ikke kan se dette, åbner du Project Explorer ved at trykke CTRL+R. Markér og kopiér (CTRL+C) flg. kode og indsæt den (CTRL+V) i fanebladets VBA-kodeark.

Private Sub Worksheet_Change(ByVal Target As Range)
'Når en celle er ændret sættes den globale
'variabel, rCell, til samme celle.
Set rCell = Target
End Sub

Trin 2: Find celler og indsæt hyperlinks

Du skal nu indsætte et modul, og øverst i modulet deklarerer du den globale rangevariabel rCell:

Public rCell As Range

Og nu til den egentlige makro. Du kan markere og kopiere (CTRL+C) koden og indsætte den i modulet (CTRL+V), eller du kan downloade det zip-komprimerede regneark.

Sub FindDubletter()
Dim bStart As Boolean
Dim bFound As Boolean
Dim lCount As Long
Dim lCelleCount As Long
Dim rSearch As Range
Dim rInsert As Range
Dim sText As String
Dim sFirstAddress As String
Dim sTargetAddress As String

On Error GoTo ErrorHandle

'Hvis der ikke er indsat noget i en celle på oversigtsarket,
'er rCelle ikke sat som rangevariabel, og makroen forlades.
If rCell Is Nothing Then
   MsgBox "Der er ikke indsat en ny tekst eller værdi."
   GoTo BeforeExit
End If

'Slår skærmopdatering fra for øget hastighed
Application.ScreenUpdating = False

'Hvis der ikke er noget at søge efter
'forlader vi proceduren.
If Len(rCell.Value) = 0 Then GoTo BeforeExit

'Den tekst vi skal finde sættes til teksten
'i den sidst ændrede celle.
sText = rCell.Value

'Vi gennemløber nu alle faneblade undtaget
'oversigtsarket.
For lCount = 1 To Worksheets.Count
   'Hvis oversigtsarket har et andet navn end "Oversigtsark"
   'skal du ændre det i linjen herunder og længere nede.
   'Brug evt. søg og erstat.
   If Worksheets(lCount).Name <> "Oversigtsark" Then
      'Området "A1:IV30000" gennemsøges for forekomster
      'af den indsatte tekst. Området kan udvides eller
      'indskrænkes i linjen herunder.
      With Worksheets(lCount).Range("A1:IV30000")
         Set rSearch = .Find(sText, LookIn:=xlValues)
         If Not rSearch Is Nothing Then
            sFirstAddress = rSearch.Address
            If bStart = False Then
               'Brugeren skal nu udpege, i hvilken celle
               'det første hyperlink skal indsættes.
               'Yderligere forekomster indsættes herunder.
               Application.ScreenUpdating = True
               Worksheets("Oversigtsark").Activate
               Set rInsert = _
               Application.InputBox(prompt:="Markér den celle," & _
               " hvor det første hyperlink skal indsættes.", Type:=8)
               Application.ScreenUpdating = False
               'Flag sættes for, at cellen er valgt, så der ikke
               'spørges igen.
               bStart = True
               Der sættes flag for, at der er fundet en dublet.
               bFound = True
            End If
						
            'Nu indsættes det første hyperlink i det aktuelle faneblad
            'på oversigtsarket.
            With Worksheets("Oversigtsark")
               sTargetAddress = _
               "'" & Worksheets(lCount).Name & "'!" & sFirstAddress
               
               .Hyperlinks.Add Anchor:=rInsert.Offset(lCelleCount, 0), _
               Address:="", SubAddress:=sTargetAddress, _
               TextToDisplay:=sTargetAddress
            End With

            'Der lægges 1 til tælleren, således at det næste hyperlink
            'indsættes i cellen under det forrige.
            lCelleCount = lCelleCount + 1

            'Nu køres en løkke, hvor vi finder evt. ekstra forekomster
            'på det aktuelle faneblad.
            Do
               rSearch.Value = sText
               Set rSearch = .FindNext(rSearch)
               If Len(rSearch.Value) > 0 _
               And rSearch.Address <> sFirstAddress Then
                  With Worksheets("Oversigtsark")
                     sTargetAddress = "'" & _
                     Worksheets(lCount).Name & "'!" & rSearch.Address
                     
                     .Hyperlinks.Add Anchor:= _
                     rInsert.Offset(lCelleCount, 0), Address:="", _
                     SubAddress:=sTargetAddress, _
                     TextToDisplay:=sTargetAddress
                  End With
                  lCelleCount = lCelleCount + 1
               End If
            Loop While Not rSearch Is Nothing _
            And rSearch.Address <> sFirstAddress
         End If
      End With
   End If
Next

If bFound = False Then
   MsgBox "Der er ikke flere forekomster af " & sText
end if

BeforeExit:
Set rInsert = Nothing
Set rSearch = Nothing
Set rCell = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure FindDubletter."
Resume BeforeExit
End Sub

Det var det. Hvis du hellere vil indsætte hyperlinksene vandret i stedet for lodret i en kolonne, skal du ændre de steder, hvor der står: