Add named ranges via loop

Hi All,

I tried adding named ranges from one workbook to another using the Microsoft guidance: https://support.microsoft.com/en-us/kb/213389, the only problem is that it causes an error on the main command that that does all the work, and so this doesn't help me understand where it is actually failing! Instead I was thinking of obtaining all the named ranges from the workbook and then writing a new macro to add them into the workbook I want them in, that way if it encounters an error, I will know which one failed! Here's what I am attempting so far:

Sub CreateNamedRange()

Dim Rng As Range
Dim RngName As String
Dim RngSheet As String
Dim RngCell As String
Dim i As Integer

For i = 1 To 2

RngName = ActiveWorkbook.Worksheets("Ranges").Cells(i, 1)
RngSheet = ActiveWorkbook.Worksheets("Ranges").Cells(i, 3)
RngCell = ActiveWorkbook.Worksheets("Ranges").Cells(i, 4)
Set Rng = Sheets(RngSheet).Range(RngCell)
ActiveWorkbook.Names.Add Name:=RngName, RefersTo:=Rng

Next i
     
End Sub

But it fails on the crucial last step. The idea is to look into a new tab in my target workbook and cycle through the list of named ranges which has the name in column 1, the sheet in column 3 and the cell reference in column 4. I've only set it up for 2 attempts at the moment but I have a long list of named ranges.

Can anyone advise if this is a good method to go about the problem, and if so where the error is? Or if there is a better way of achieving the same outcome.

Thank you in advance,

Tom!

Apologies for the omittance - see attached!

Tom