Consulta Impresión de valores en celdas de un rango

Hola a todos!

Tengo el siguiente caso, necesito crear una macro que lea las celdas de un rango y en la celda equivalente en otro rango imprima un valor dependiendo de los 3 primeros caracteres que ha extraído. Es decir, si en la celda d2 el valor es "z10" que en la b2 escriba "Empresa 1".

Para ello había desarrollado el siguiente código en vba, pero no compila.

Sub Sociedad()
'
' Sociedad Macro
'
'
Dim i As Integer
Dim rango1 As Range
Dim rango2 As Range
Dim celda As Object
Dim Hoja As Object

Set Hoja = Sheets("Flota Final")
Set rango1 = Range("d2:d65000")
Set rango2 = Range("a2:a65000")

For Each celda In rango1
If Left(rango1.celda.Value, 3) = "z10" Then
'rango2.celda.Value "Empresa 1"
rango2.ActiveCell.Value = "Empresa 1"

ElseIf Left(rango1.ActiveCell.Value, 3) = "z20" Then
rango2.ActiveCell.Value = "Empresa 2"

ElseIf Left(rango1.ActiveCell.Value, 3) = "z31" Then
rango2.ActiveCell.Value = "Empresa 3"

ElseIf Left(rango1.ActiveCell.Value, 3) = "z41" Or Left(rango1.ActiveCell.Value, 4) = "z041" Then
rango2.ActiveCell.Value = "Empresa 4"

ElseIf Left(rango1.ActiveCell.Value, 3) = "z42" Or Left(rango1.ActiveCell.Value, 4) = "z042" Then
rango2.ActiveCell.Value = "Empresa 5"

ElseIf Left(rango1.ActiveCell.Value, 3) = "z43" Or Left(rango1.ActiveCell.Value, 4) = "z043" Then
rango2.ActiveCell.Value = "Empresa 6"

End If

Next

End Sub

Espero me podáis ayudar.

Gracias!

Javier