Dinamic Validations Lists

Hi I am using in the Validation the formula :
=OFFSET(INDIRECT(SUBSTITUTE($A40,"
","")),0,0,COUNTA(INDIRECT(SUBSTITUTE($A40," ","")&"Col")),1)

And also I am using the next code for letting add new elements to my lists :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aux As String
Dim i As Integer
Dim allowedVal As Boolean
On Error Resume Next
Dim ws As Worksheet
Dim rngDV As Range
Dim rng As Range

'Add items to list
If (Target.row >= 13 And Target.row <= 31) And (Target.Column = 12 Or
Target.Column = 15 Or Target.Column = 18 Or Target.Column = 21 Or
Target.Column = 24 Or Target.Column = 27 Or Target.Column = 30 Or
Target.Column = 33 Or Target.Column = 36 Or Target.Column = 39) Then
If Target.count > 1 Then Exit Sub
Set ws = Worksheets("DATA-GEx Data")
If Target.row > 1 Then

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0
If rngDV Is Nothing Then Exit Sub
If Intersect(Target, rngDV) Is Nothing Then Exit Sub
Set rng = ws.Range(ActiveWorkbook.Sheets("Part Appl
Guidelines").Cells(Target.row + 27, 1).Value)
If Application.WorksheetFunction.CountIf(rng, Target.Value) Then
Exit Sub
Else
i = ws.Cells(Rows.count, rng.Column).End(xlUp).row + 1
'we need to resize the range
ws.Cells(i, rng.Column).Value = Target.Value

Set rng = ws.Range(ActiveWorkbook.Sheets("Part Appl
Guidelines").Cells(Target.row + 27, 1).Value)
'With Worksheets("DATA-GEx Data").Range("J" & Trim(Str(row))).Font
' .ColorIndex = 3
' .Size = 10
' .Bold = False
'End With
rng.Sort Key1:=ws.Cells(1, rng.Column), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End If
End If

But when I add a new element to the list ... the element is added but the
range is not being resized , I think so because it is letting to add the same
element more than once.

Could you please help me ?

Regards