Sortering af hyperlinks i Excel med VBA (makroer)

Der er en bug (fejl) i Excel, som betyder, at der kommer fejl i hyperlinksene, hvis man sorterer cellerne, de står i.

Er det noget, man skal gøre jævnligt, er der heldigvis en smutvej ved at bruge VBA, og jeg viser på denne side, hvad man kan gøre.

Sortering med kopiering

Jeg prøvede alt muligt "snedigt" i VBA, men de sorterede hyperlinks var som forheksede. Det var som at skære toppen af en porre på sit køkkenbord og så se alle porretoppene i køkkenhaven ryge af på samme tid!

Til sidst valgte jeg den lidet elegante, men uhyre simple løsning, nemlig at sortere ved kopiering. Linksene kan nemlig godt tåle kopiering.

Eksemplet herunder forudsætter, at du har en tabel med to kolonner startende i celle A1 på faneblad 1. Cellerne med hyperlinks er i kolonne B. Tabellen kan fx stå alfabetisk efter firmanavne i kolonne A, og nu vil du i stedet sortere den efter personnavne med hyperlinks i kolonne B.

Det første, vi gør, er at kopiere tabellen til samme område på faneblad 2 (det kan være hvor som helst). Herefter nummererer vi rækkerne fra celle C1 og ned, til den nye tabel slutter. Det er fidusens første trin!

Dernæst sorterer vi den nye tabel inklusive rækkenumrene i kolonne C. Sorteringsnøglen er personnavnene i kolonne B.

Da rækkenumrene blev sorteret med, fulgte de nabocellerne i kolonne B, og vi kan nu bruge de gamle rækkenumre til at identificere de tilsvarende "sunde" celler i den originale tabel.

Nu er det bare at overskrive de sorterede, "syge" hyperlinks med originalerne og til slut fjerne kolonne C med rækkenumrene.

I eksemplet bruger jeg "CurrentRegion" til at finde tabellens udstrækning, og det kan man kun gøre, hvis tabellen er "afgrænset" af blanke celler. Hvis den støder op til andre celler med indhold, som ikke hører til tabellen, må man definere sit range på anden vis.

Du kan markere koden med musen, kopiere (CTRL+C) og indsætte den i et Excel VBA-modul (CTRL+V).

Sub SorterHyperlinks()

Dim rTabelOrig As Range
Dim rTabelKopi As Range
Dim rCell As Range
Dim lCount As Long

On Error GoTo ErrorHandle

'Undertrykker skærmopdatering.
Application.ScreenUpdating = False

Worksheets(1).Activate

'Vi sætter ranget rTabelOrig = tabellen,
'som skal kopieres. Eksemplet forudsætter,
'at tabellen starter i celle A1, at den
'har to kolonner, og at hyperlinksene er
'i kolonne B. Brugen af "CurrentRegion"
'forudsætter tilmed, at tabellen har
'tomme celler som "grænse".
Set rTabelOrig = Range("A1").CurrentRegion

'Tabellen kopieres til næste faneblad.
rTabelOrig.Copy (Worksheets(2).Range("A1"))

'Inden vi går videre, redefinerer vi rTabelOrig
'til kun at omfatte cellerne med hyperlinks. Det
'får vi brug for senere.
Set rTabelOrig = Range(Range("B1"), Range("B1").End(xlDown))

Worksheets(2).Activate

'rTabelKopi sættes = den kopierede tabel.
Set rTabelKopi = Range("A1").CurrentRegion

'Vi indsætter nu rækkenumre i kolonne C.
For lCount = 1 To rTabelKopi.Rows.Count
   Range("C1").Offset(lCount - 1, 0).Value = lCount
Next

'Vi vælger nu hele tabellen inklusive kolonne C
'hvor vi lige har indsat rækkenumre.
Range("A1").CurrentRegion.Select

'Tabellen sorteres nu.
'(Hvis der er kompatibilitetsproblemer fra Excel 2000
'til Excel ???, kan følgende forsøges erstattet af kode
'genereret af "makrooptageren".)
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, _
Key2:=Range("A1"), Order2:=xlAscending, _
Key3:=Range("C1"), Order3:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

'rTabelKopi redefineres til kun at
'omfatte de sorterede hyperlinks.
Set rTabelKopi = Range(Range("B1"), Range("B1").End(xlDown))

'Nu overskrives de sorterede hyperlinks med de originale. Til at
'identificere de originale, bruger vi de sorterede rækkenumre.
With rTabelOrig
   For Each rCell In rTabelKopi
      .Item(rCell.Offset(0, 1).Value).Copy rCell
   Next
End With

'Nu sletter vi kolonnen med gamle rækkenumre.
rTabelKopi.Offset(0, 1).Clear

BeforeExit:
Set rTabelKopi = Nothing
Set rTabelOrig = Nothing
Set rCell = Nothing
Application.ScreenUpdating = True

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure SorterHyperlinks."
Resume BeforeExit
End Sub