Traitement codes long

Bonjour,

Peut-on accélérer le traitement de ces codes svp
En vous remerciant.

Private Sub Worksheet_Change(ByVal Target As Range)
If Application.CountA(Range("F5")) = 0 Then Exit Sub
If Not Intersect(Target, Range("F5")) Is Nothing Then 'mettre après then le nom de la macro à executer
Ecrire
End If
End Sub

Sub Ecrire()
Application.ScreenUpdating = False
Logo
With Sheets("EC").Select
[B1] = "ASSOCIATION D'ENTRAIDE "
[B2] = "AUX PERSONNES EN DIFFICULTES"
End With

[B1:B2].Select
With Selection.Font
.Name = "Times New Roman"
.Size = 16
.ColorIndex = 1
Selection.Font.Bold = True
End With

[B1:E2].Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With

[B5].Select
[B5] = "Fiche individuelle concernant :"
With Selection.Font
.Name = "Times New Roman"
.Size = 14
Selection.Font.Bold = True
End With

[B5].Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
End With

[B5].Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With

[A8] = "Nom :"
[A9].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C,MATCH(EC!R5C6,Base!C24,1))),"""",INDEX(Base!C,MATCH(EC!R5C6,Base!C24,1)))"
[B9].Select
[B8] = "Prénom :"
[B9].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C,MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C,MATCH(EC!R5C6,Base!C24,0)))"
[A11] = "Né(e) le :"
[A12].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[2],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[2],MATCH(EC!R5C6,Base!C24,0)))"
[B11] = "Commune :"
[B12].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[2],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[2],MATCH(EC!R5C6,Base!C24,0)))"
[C11] = "Dpt ou CP :"
[C12].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[2],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[2],MATCH(EC!R5C6,Base!C24,0)))"
[A14] = "Demeurant :"
[A15].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[9],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[9],MATCH(EC!R5C6,Base!C24,0)))"
[B14] = "Complément adresse :"
[B15].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[9],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[9],MATCH(EC!R5C6,Base!C24,0)))"
[C14] = "CP :"
[C15].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[9],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[9],MATCH(EC!R5C6,Base!C24,0)))"
[D14] = "Commune :"
[D15].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[9],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[9],MATCH(EC!R5C6,Base!C24,0)))"
[A17] = "Tél Fixe :"
[A18].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[5],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[5],MATCH(EC!R5C6,Base!C24,0)))"
[B17] = "Tél Portable :"
[B18].FormulaR1C1 = "=IF(ISERROR(INDEX(Base!C[5],MATCH(EC!R5C6,Base!C24,0))),"""",INDEX(Base!C[5],MATCH(EC!R5C6,Base!C24,0)))"
[A8:B8,A11:C11,A14:D14,A17:B17].Select
With Selection.Font
.Name = "Times New Roman"
.Size = 8
End With
Selection.Font.Italic = True
' ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1 'Imprimer
ActiveWindow.SelectedSheets.PrintPreview 'Prévisualiser
RazLogo
Application.ScreenUpdating = True
End Sub

Sub Logo()
Dim F As Worksheet, Nom As String
Application.ScreenUpdating = False
'La feuille avec le logo doit être la feuille active
Worksheets("Img").Visible = True
Sheets("Img").Activate
ActiveSheet.Pictures("Picture 5").Name = "Logo"
ActiveSheet.Shapes("Logo").Copy
Nom = ActiveSheet.Name
Sheets("EC").Activate
Range("A1").Select
ActiveSheet.Paste
Selection.Name = "Logo"
Selection.ShapeRange.Left = 1.5
Selection.ShapeRange.Top = 1.5
Worksheets("Img").Visible = False
Application.ScreenUpdating = True
End Sub
Sub RazLogo()
Range("A1:E18,F5").ClearContents
ActiveSheet.Shapes("Logo").Delete
[F5].Select
End Sub