Hvorfor laver dette array alt for mange "pladser"? Noget galt med redimen

Er dette en optimalløsning?


Sub unikke()

Dim VRng As Range, XRng As Range
Dim VXBol As Boolean

Dim VRngArray() As Variant
Dim XRngArray() As Variant


Set VRng = Range(ThisWorkbook.Worksheets("Ark1").Range("A1"), ThisWorkbook.Worksheets("Ark1").Range("A65000").End(xlUp))

UniqueX = 1


VRngArray = VRng.Value
ReDim XRngArray(UniqueX)

For i = 1 To UBound(VRngArray)

   
   
    ReDim Preserve XRngArray(UniqueX)

    VXBol = False
       
        For v = 1 To UBound(XRngArray)
       
            If XRngArray(v) = VRngArray(i, 1) Then
                VXBol = True
            End If
   
        Next

    If VXBol = False Then
       
        XRngArray(UniqueX) = VRngArray(i, 1)
    UniqueX = UniqueX + 1
    End If

    Debug.Print UBound(XRngArray)
    Debug.Print XRngArray(UniqueX - 1)

Next

End Sub

Sub unikke()

Dim VRng As Range, XRng As Range
Dim VXBol As Boolean

Dim VRngArray() As Variant
Dim XRngArray() As Variant


Set VRng = Range(ThisWorkbook.Worksheets("Ark1").Range("A1"), ThisWorkbook.Worksheets("Ark1").Range("A65000").End(xlUp))

UniqueX = 1


VRngArray = VRng.Value
'ReDim XRngArray(UniqueX)

For i = 1 To UBound(VRngArray)

   
   
    ReDim Preserve XRngArray(UniqueX)

    VXBol = False
       
        For v = 1 To UBound(XRngArray)
       
            If XRngArray(v) = VRngArray(i, 1) Then
                VXBol = True
            End If
   
        Next

    If VXBol = False Then
       
        XRngArray(UniqueX) = VRngArray(i, 1)
    UniqueX = UniqueX + 1
    End If

   
    'Debug.Print UBound(XRngArray)
    'Debug.Print XRngArray(UniqueX - 1)

Next

For l = 1 To UBound(XRngArray)
    Debug.Print XRngArray(l)
Next


'Sort array

    For lLoop = 0 To UBound(XRngArray)

      For lLoop2 = lLoop To UBound(XRngArray)

            If XRngArray(lLoop2) < XRngArray(lLoop) Then

                str1 = XRngArray(lLoop)

                str2 = XRngArray(lLoop2)

                XRngArray(lLoop) = str2

                XRngArray(lLoop2) = str1

            End If

        Next lLoop2

    Next lLoop

   

    'Output sorted array

    Worksheets("Ark1").Range("B1:B" & UBound(XRngArray) + 1) = WorksheetFunction.Transpose(XRngArray)


End Sub

lukker