Happy Friday!
The code below processes the first row and never moves to the second row. What am I doing wrong here?
The code below processes the first row and never moves to the second row. What am I doing wrong here?
VBA Code:
Sub TestForHyperlinkAndFix()
Settings.MessageReturn.Value = "Rebuilding all Hyperlinks."
Settings.Repaint
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Unprotect
Sheets("Hyperlinks").Visible = True
Sheets("Calendar").Range("J5").Select
Dim i As Long
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow Step 1
If Cells(ActiveCell.Row, "J").Hyperlinks.Count > 0 Then
Range(Cells(Selection.Row, 10).Address).Select
Range(ActiveCell.Address).Name = "StartCell"
Sheets("Hyperlinks").Range("F1") = Sheets("Calendar").Range("StartCell")
Sheets("Hyperlinks").Range("A1") = Sheets("Calendar").Range("C" & ActiveCell.Row).Value
Sheets("Calendar").Select
Application.GoTo "StartCell"
ThisWorkbook.Names("StartCell").Delete
Dim newRange As Range
Set newRange = Range(ActiveCell, ActiveCell.Offset(NumRows, numCols))
With ActiveSheet
.Hyperlinks.Add Anchor:=newRange, _
Address:=Sheets("Hyperlinks").Range("I1"), TextToDisplay:=ActiveCell.Text
End With
Else
End If
Next i
Sheets("Hyperlinks").Visible = False
'Protect Calendar
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows:=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Settings.MessageReturn.Value = "All Hyperlinks successfully rebuilt."
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub