Один документ привести к виду другого

Sub Макрос1()
 
    Dim asd$, fgh$, fgh2$, k As Long, rt As Long
    Sheets.Add After:=Sheets(Sheets.Count)
    asd = ActiveSheet.Name
    k = 2
    Cells(1, 1) = "№ П/П"
    Cells(1, 2) = "День посещения"
    Cells(1, 3) = "Агент"
    Cells(1, 4) = "id_census"
    Cells(1, 5) = "Наименование"
    Cells(1, 6) = "Адрес"
    Cells(1, 7) = "Клиент"
    Sheets("Page 1").Select
    For i = 1 To 65535
    If InStr(1, Cells(i, 1), "Агент:") > 0 Then
    fgh = Replace(Cells(i, 1), "Агент:", "")
    Else
        If Cells(i, 1) = "День посещения:" Then
        fgh2 = Mid(Cells(i, 3), InStr(1, Cells(i, 3), "/") + 1)
        Else
            If fgh <> "" And fgh2 <> "" And Cells(i, 1) <> "" Then
            Sheets(asd).Cells(k, 1) = Cells(i, 1)
            Sheets(asd).Cells(k, 2) = fgh2
            Sheets(asd).Cells(k, 3) = fgh
            Sheets(asd).Cells(k, 4) = Cells(i, 2)
            Sheets(asd).Cells(k, 5) = Cells(i, 3)
            Sheets(asd).Cells(k, 6) = Cells(i, 4)
            Sheets(asd).Cells(k, 7) = Cells(i, 6)
            k = k + 1
        End If
    End If
    End If
    If Cells(i, 1) = "" Then rt = rt + 1
    If rt > 10 Then Exit For
    Next i
End Sub