VB kode update

Er der en som kan gøre at den med tager de 2 celler som er under søgeværdien og værdien den ellers tager

Sub Get_driver1()
Dim arr(254, 1)
Dim arr2(59)
Dim i, o, p As Integer
Dim rng As Range
Dim FindDato As String

'------------------------------------

Workbooks("09-08-06.xls").Activate
Sheets("1").Activate
FindDato = Cells(1, 11).Text
'------------------------------------
Application.ScreenUpdating = False
On Error Resume Next
Workbooks("Planark.xls").Activate
If Err.Number <> 0 Then Workbooks.Open "G:\DOKUMENTER\Kørsel\Ny Bemanding\Chauffører\Test\Planark.xls"

Sheets("jan").Select

Set rng = Range("A:A")

For Each k1 In rng
    If k1.Text = FindDato Then
        p = k1.Row
        Exit For
   
    End If
Next k1
Set rng = Range("A:A")
'------------------------------------
For i = 1 To 254
    arr(i - 1, 0) = Cells(p, i).Value
    arr(i - 1, 1) = Cells(1, i).Value
Next i
'------------------------------------
ActiveWorkbook.Save
ActiveWorkbook.Close
'------------------------------------
Workbooks("09-08-06.xls").Activate
Sheets("1").Activate
For i = 0 To 59
Cells(i + 4, 1).Select
    arr2(i) = Cells(i + 4, 1).Value
Next i
'------------------------------------

Sheets("1").Activate

For i = 0 To 59
p = i + 4
    For o = 1 To 254
        If arr(o, 0) = arr2(i) Then
            Cells(p, 14).Value = arr(o + 1, 0)
            Cells(p, 3).Value = arr(o, 1)
            Exit For
      End If
    Next o
Next i
Application.ScreenUpdating = True
Call Fon
End Sub