Trying to speed up my Hyperlink restoration macro

[jmpatrick]

Good morning!

I've been using this code to restore the colors of several thousand hyperlinks on my sheet. It gets the job done but it's too darn slow. Here's the code:

Sub RestoreFormatting()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim hl As Hyperlink
        
    'Restore Hyperlink Color
    For Each hl In Range("CalendarHyperlinks").Hyperlinks
    hl.Range.Font.Color = RGB(0, 0, 255)
    Next
    
    'Restore SubLotColumn Hyperlinks
    For Each hl In Range("SubLotColumn").Hyperlinks
    hl.Range.Font.Color = RGB(0, 0, 0)
    Next
    
    'Restore CalendarFieldManagersColumn Color
    For Each hl In Range("CalendarFieldManagersColumn").Hyperlinks
    hl.Range.Font.Color = RGB(0, 0, 0)
    Next
    
    'Restore CalendarLinkRow Color
    For Each hl In Range("CalendarLinkRow").Hyperlinks
    hl.Range.Font.Color = RGB(0, 0, 255)
    Next
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

 

[Legacy 143009]

I think this can go no faster than this:

Sub RestoreFormatting()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    Range("CalendarHyperlinks,CalendarLinkRow").Font.Color = RGB(0, 0, 255)

    Range("SubLotColumn,CalendarFieldManagersColumn").Font.Color = RGB(0, 0, 0)
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

 

[jmpatrick]

I think this can go no faster than this:

Sub RestoreFormatting()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    Range("CalendarHyperlinks,CalendarLinkRow").Font.Color = RGB(0, 0, 255)

    Range("SubLotColumn,CalendarFieldManagersColumn").Font.Color = RGB(0, 0, 0)
  
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
  
End Sub

That works but it reformats everything in the named range, not just the hyperlinks.

 

[Legacy 143009]

You are right. A possible workaround could be:

Sub RestoreFormatting()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
   
    Range("CalendarHyperlinks").AutoFilter Field:=1, Criteria1:="=http*", Operator:=xlAnd
    Range("CalendarHyperlinks").Font.Color = RGB(0, 0, 255)
    AutoFilterMode = False
    Range("CalendarLinkRow").AutoFilter Field:=1, Criteria1:="=http*", Operator:=xlAnd
    Range("CalendarLinkRow").Font.Color = RGB(0, 0, 255)
    AutoFilterMode = False
    Range("SubLotColumn").AutoFilter Field:=1, Criteria1:="=http*", Operator:=xlAnd
    Range("SubLotColumn").Font.Color = RGB(0, 0, 0)
    AutoFilterMode = False
    Range("CalendarFieldManagersColumn").AutoFilter Field:=1, Criteria1:="=http*", Operator:=xlAnd
    Range("CalendarFieldManagersColumn").Font.Color = RGB(0, 0, 0)
    AutoFilterMode = False

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
End Sub

 

[jkpieterse]

I suggest this:

Sub RestoreFormatting()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Dim hl As Hyperlink
    Dim rng As Range

    For Each hl In Range("
CalendarHyperlinks,CalendarLinkRow,SubLotColumn,CalendarFieldManagersColumn").Hyperlinks
        If rng Is Nothing Then
            Set rng = hl.Range
        Else
            Set rng = Union(rng, hl.Range)
        End If
    Next
    If Not rng Is Nothing Then rng.Font.Color = vbBlack
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

 

[jmpatrick]

I suggest this:

Sub RestoreFormatting()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    Dim hl As Hyperlink
    Dim rng As Range

    For Each hl In Range("
CalendarHyperlinks,CalendarLinkRow,SubLotColumn,CalendarFieldManagersColumn").Hyperlinks
        If rng Is Nothing Then
            Set rng = hl.Range
        Else
            Set rng = Union(rng, hl.Range)
        End If
    Next
    If Not rng Is Nothing Then rng.Font.Color = vbBlack
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
End Sub

Thanks to both of you for the help.

This works.