Redim Preserve on loop cause an error of Subscript out of range

Im looping a folder and passing different elements to an array dynamically. When the array is empty and i ReDim it the array increase size but when the array has values and i try to ReDim Preserve i got an erro of:

Subscript out of range

Code:

Dim arrNames As Variant

Do While Len(StrFile) > 0

    'If array is empty
    If Counterarr = 0 Then
        'Add a line to the array
        ReDim arrNames(Counterarr, 1 To 3)
    Else
        'Keep the values and add new
        ReDim Preserve arrNames(Counterarr)
    End If

    'Import document name
    arrNames(Counterarr, 1) = Trim(Replace(Trim(StrFile), ".xlsx", ""))
    'Import Year
    arrNames(Counterarr, 2) = Trim(Left(Trim(Split(Trim(Replace(Trim(StrFile), ".xlsx", "")), "")(1)), 4))
    'Import Month
    arrNames(Counterarr, 3) = Right(Trim(Split(Trim(Replace(Trim(StrFile), ".xlsx", "")), "")(1)), 2)

    Counterarr = Counterarr + 1

    StrFile = Dir

Loop

Image:

When array initialized:

Any advice how to import ArrNames(1) etc?