Tengo un problema en el REDIN PRESERVE y no veo el fallo. Estoy con Excel 2007.

Private Sub Carga()
Dim I As Integer, Matriz() As String, J As Integer
Dim Pos As Integer, NumReg As Integer
Application.ScreenUpdating = False
NumReg = 1: Pos = NumReg - 1
ReDim Matriz(Pos, 0 To 3)
Range("A1").Select
Do While ActiveCell <> Empty
celda = ActiveCell.Address
Matriz(Pos, 0) = Range("A" & NumReg) Linea del error, se produce a la segunda pasada
Matriz(Pos, 1) = Range("B" & NumReg)
Matriz(Pos, 2) = Range("C" & NumReg)
Matriz(Pos, 3) = Range("D" & NumReg)
NumReg = NumReg + 1: Pos = NumReg - 1
ReDim Preserve Matriz(Pos, 0 To 3)
ActiveCell.Offset(1, 0).Select
Range("A" & NumReg).Select
Loop
Dim Item As ListItem
frmAlimentación.Alimentación.ListItems.Clear
For I = 0 To UBound(Matriz) - 1
For J = 0 To 3
Set Item = frmAlimentación.Alimentación.ListItems.Add(, , Matriz(I, J))
Item.SubItems(J + 1) = Matriz(I, J)
Next J
Next I
frmAlimentación.Alimentación.View = lvwReport
Application.ScreenUpdating = True
End Sub