Remove hyperlinks while retaining formatting

[scottcolbury]

Hi,
I have some legacy workbooks with embedded hyperlinks that I need to get rid of.
I know how to remove the links, but when doing so Excel resets the number formatting to general, removes colors, bold, italics, etc, etc. I need to retain this formatting.

I tried copying the cell to then use paste special:formatting, but that does not work.
Here is version of my code.

        With ActiveSheet
            LastRow = .Cells(65536, 2).End(xlUp).Row
            'test all cells with visible data
            For x = 1 To LastRow
                For y = 1 To 256
                    Application.StatusBar = "x = " & x & " of " & LastRow & " : y = " & y
                    If .Cells(x, y).Hyperlinks.Count > 0 Then
                        .Cells(x, y).Hyperlinks(1).Delete
                    End If
                Next y
            Next x
        End With

thanks
s_c

 

[VoG]

That could be replaced with

ActiveSheet.Hyperlinks.Delete

 

[scottcolbury]

Yes, I know the shorter code will work... but that still doesn't help me with my problem of retaining the formatting.
s_c

 

[Andrew Poulsom]

A hyperlink cell has the Hyperlink style, or the Followed Hyperlink style if it has been clicked.

 

[VoG]

Try (on a copy of your sheet)

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ActiveSheet
ActiveSheet.Copy after:=ActiveSheet
Set ws2 = ActiveSheet
ws1.Hyperlinks.Delete
ws2.UsedRange.Copy
ws1.Range("A1").PasteSpecial Paste:=xlPasteFormats
ws1.Select
Application.DisplayAlerts = False
ws2.Delete
Application.DisplayAlerts = True
End Sub

 

[scottcolbury]

Thanks Andrews, but that wasn't the kind of formatting I was referring to.
I'm talking about the formatting I do regardless if the hyperlink has been clicked.
s_c

 

[scottcolbury]

Thanks VoG,
This code works for the most part, but XLS won't paste formats over array formulas at this line:

ws1.Range("A1").PasteSpecial Paste:=xlPasteFormats

... and the code breaks.
Any ideas?

s_c

 

[VoG]

This may take a while to run with a large sheet but will skip cells that cause errors:

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, c As Range
Application.ScreenUpdating = False
Set ws1 = ActiveSheet
ActiveSheet.Copy after:=ActiveSheet
Set ws2 = ActiveSheet
ws1.Hyperlinks.Delete
On Error Resume Next
For Each c In ws2.UsedRange
    c.Copy
    ws1.Range(c.Address).PasteSpecial Paste:=xlPasteFormats
Next c
On Error GoTo 0
ws1.Select
Application.DisplayAlerts = False
ws2.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub