Out of Memory

[adavid]

Below is my code for updating hyperlink addresses that were corrupted. I can update the hyperlinks in very small batches, but the sheet has almost 3000 rows. All of the hyperlinks are in column B. Any suggestions or code optimization would be very helpful.

Sub FixHLinks(sFind As String, sReplace As String, _
    Optional lStart As Long = 1, Optional lCount As Long = -1)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim rCell As Range
    Dim hl As Hyperlink

'THIS WAS FOR TESTING PURPOSES
    For Each rCell In ActiveSheet.Range("B461:B561")
'THIS IS IDEAL
    'For Each rCell In ActiveSheet.UsedRange.Cells
        If rCell.Hyperlinks.Count > 0 Then
            For Each hl In rCell.Hyperlinks
                hl.Address = Replace(hl.Address, sFind, sReplace, lStart, lCount, vbTextCompare)
            Next hl
        End If
    Next rCell
 Set rCell = Nothing
 Set hl = Nothing
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

'THE ABOVE CODE IS CALLED FROM THE CODE BELOW
Sub FixThem()
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
    FindReplaceHLinks "../AppData/Roaming/Microsoft/Excel/", "\\NetworkShare\Folder1\Folder2\Folder3\"
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

 

[adavid]

I modified your code for my column and paths. It just deleted all of the hyperlinks.

I rewrote the code to the code below and it worked for about 600 rows before I got the error that I ran out of memory.

Sub FixLinks(oString As String, nString As String, Optional lStart As Long = 1, Optional lCount As Long = -1)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Dim i As Integer, j As Integer
Dim hLink As Hyperlink
Dim wSheet As Worksheet
Dim wRange As Range
    Set wRange = Sheet10.Range("B:B")
Dim rCell As Object
'Dim oString As String
    'oString = "../AppData/Roaming/Microsoft/Excel/"
'Dim nString As String
    'nString = "\\marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\"
   
     NumRows = Range("B3", Range("B3").End(xlDown)).Rows.Count
     Range("B3").Select
    ' Establish "For" loop to loop "numrows" number of times.
   
    '  For i = 1 To wRange.Rows(3, 2)
     '  With wRange
       For Each rCell In wRange
        If ActiveCell.Hyperlinks.Count > 0 Then
         For Each hLink In ActiveCell.Hyperlinks
            hLink.Address = Replace(hLink.Address, oString, nString, lStart, lCount)
         Next hLink
        End If
         ' Selects cell down 1 row from active cell.
         ActiveCell.Offset(1, 0).Select
       Next rCell
       'End With
      'Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
   End Sub
 
Sub PleaseWork()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    FixLinks "../AppData/Roaming/Microsoft/Excel/", \\marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Hi, to recreate a set-up similar to yours I created a new blank workbook and ran the following code to create 3000 hyperlinks:

Sub SetUp()
Dim i As Long
Application.ScreenUpdating = False
Columns("A").Delete
For i = 1 To 3000
    ActiveSheet.Hyperlinks.Add Cells(i, 1), Address:="https://uk.search.yahoo.com/search?p=" & CStr(i), TextToDisplay:=CStr(i)
Next i
End Sub

I then ran this:

Sub FixThem()
FixHLinks "uk.search.yahoo.com/search?p=", "www.bing.com/search?q="
End Sub

With the FixHLinks code as:

Sub FixHLinks(sFind As String, sReplace As String, _
    Optional lStart As Long = 1, Optional lCount As Long = -1)
    
    Dim hl As Hyperlink
    
    For Each hl In ActiveSheet.Hyperlinks
        hl.Address = Replace(hl.Address, sFind, sReplace, lStart, lCount, vbTextCompare)
    Next hl


End Sub

And it executed in less than a second - if you do the same with a new blank workbook do you get the same sub second response without any memory errors?

 

[FormR]

it executed in less than a second - if you do the same with a new blank workbook do you get the same sub second response without any memory errors?

Did you try this test? What was the result?

I modified your code for my column and paths. It just deleted all of the hyperlinks.

Can you post the modified code?

 

[adavid]

Look up, it's the post right before yours

 

[FormR]

Look up, it's the post right before yours

That's nothing like the code I posted !

 

[adavid]

Oh my apologies; that code isn't yours, but yes I will post the modified code.

 

[FormR]

It's getting late in my little corner of the world so if no-one else jumps in in the meantime it will be tomorrow before I reply.

 

[Andrew Poulsom]

That's nothing like the code I posted !

Not only that, but it uses ActiveCell rather than rCell.

 

[adavid]

FormR, here is the your code adapted with my edits.

Sub SetUp()
Dim i As Long
Application.ScreenUpdating = False
Columns("A").Delete
For i = 1 To 3000
    ActiveSheet.Hyperlinks.Add Cells(i, 1), Address:="../AppData/Roaming/Microsoft/Excel/" & CStr(i), TextToDisplay:=CStr(i)
Next i
End Sub


Sub FixThem()
FixHLinks "../AppData/Roaming/Microsoft/Excel/", "\\marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\"
End Sub


Sub FixHLinks(sFind As String, sReplace As String, _
    Optional lStart As Long = 1, Optional lCount As Long = -1)
    
    Dim hl As Hyperlink
    
    For Each hl In ActiveSheet.Hyperlinks
        hl.Address = Replace(hl.Address, sFind, sReplace, lStart, lCount, vbTextCompare)
    Next hl


End Sub

 

[adavid]

Thanks Andrew, not sure why I did that

Not only that, but it uses ActiveCell rather than rCell.

 

[FormR]

FormR, here is the your code adapted with my edits.

Hi, the purpose of the code in post#10 was to create a test scenario - I was suggesting that you run the code unedited on a new blank workbook to see if it ran quickly without causing the memory error.