VBA: Multiple named ranges offset from single column

[mrMozambique]

Hi all. I have a two columns of data. I'm trying to create named ranges in the second column of data based on the contents of the first. The first column is sorted. Here's an example of my data:

A 5
A 7
A 8
B 9
B 6
B 8
B 0

In the above example, I will be creating two ranges named A and B. A's range will contain 5,7,8 and B's range will contain 9,6,8,0. The code below appears to create the ranges only in a single column, not in the adjacent column. Can anyone help me create the above scenario where the adjacent cells are the range? Thanks in advance for any help! MrExcel has saved me countless times so I'm hoping it can come through again.

Sub AddDynamicRangeVertical()
    On Error Resume Next
    Dim sRangeName As String
    Dim n As Name

    If ActiveWorkbook Is Nothing Then Exit Sub

    sRangeName = InputBox("Enter a range name, then push OK. ", _
    "Add Vertical Dynamic Range")

    If sRangeName = "" Then Exit Sub

    sRangeName = Replace(sRangeName, " ", "_")

    ActiveWorkbook.Names.Add Name:=sRangeName, _
    RefersTo:="=OFFSET(" & ActiveSheet.Name & "!" _
    & ActiveCell.Address & ",,,COUNTA(" & ActiveSheet.Name _
    & "!" & Columns(ActiveCell.Column).Address & "))"

    For Each n In ActiveWorkbook.Names
        If n.Name = sRangeName Then Exit Sub
    Next n

    MsgBox Err.Description, , "Invalid Name"

    On Error GoTo 0
End Sub