Ways to optimize codes

Question

I have written a code in VBA editor (Excel). Basically the code defines which project this is (because there are multiple sheets working with this code). Then it copies and paste the data in the right column and row in an overview workbook (where all the files send their data). So I get a nice overview of my projects.

But now I like to optimize my code so it's faster. I have two different codes, one of the codes is shown below.

I'm aware of making my codes faster with disabling things like screen updating and calculations.

My question is: How can I improve the code itself?

Option Explicit
Private Sub SyncToBureauplanner()

On Error GoTo Errormessage

'|  Define current projectplanner
    Dim Projectnumber As String
        Projectnumber = ActiveWorkbook.Sheets("Planning").Range("A6").Value2

    Dim Projectplanner As String
        Projectplanner = Projectnumber & ".xlsm"

'|  Define this week then find the column of this week
    Dim Currentweek As String
        Currentweek = Workbooks(Projectplanner).Sheets("Planning").Range("B5").Value2

    Dim CurrentweekColumn As Range
        With Workbooks(Projectplanner).Sheets("Planning").Range("2:2")
            Set CurrentweekColumn = .Find(What:=Currentweek, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False, Searchformat:=False)
        End With

'|  Define phasedata range
    Dim PhaseStart As Range
    Dim PhaseEnd As Range
    Dim Phasedata As Range

         With Workbooks(Projectplanner).Sheets("Planning")
            Set PhaseStart = .Range(Cells(9, CurrentweekColumn.Column).Address)
            Set PhaseEnd = .Range(Cells(10, CurrentweekColumn.Offset(0, 106).Column).Address)
            Set Phasedata = .Range(PhaseStart, PhaseEnd)
        End With

'|  Locate the Bureauplanning and open it | Disable filters
    Dim BureauplannersPath As String
        BureauplannersPath = "J:\Planning\Bureauplanning\"

    Dim Bureauplanner As String
        Bureauplanner = "Bureauplanning.xlsm"

    Dim BureauplannersFile As String
        BureauplannersFile = BureauplannersPath & Bureauplanner

        Workbooks.Open (BureauplannersFile)
            Workbooks(Bureauplanner).Sheets("planning").Activate
                If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData


'|  Define column where Phasedata is going to be pasted
    Dim CurrentWeekBureauplanner As Range
        With Workbooks(Bureauplanner).Sheets("planning").Range("L2:DO2")
            Set CurrentWeekBureauplanner = .Find(What:=Currentweek, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False, Searchformat:=False)
                If Not CurrentWeekBureauplanner Is Nothing Then
                End If
    End With

'|  Define row where Phasedata is going to be pasted
    Dim ThisProjectRow As Range
        With Workbooks(Bureauplanner).Sheets("planning").Range("A:A")
            Set ThisProjectRow = .Find(What:=Projectnumber, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False, Searchformat:=False)
                If Not ThisProjectRow Is Nothing Then
                End If
        End With

'|  Define range where Phasedata is going to be pasted
    Dim PasteStartCell As Range
    Dim PasteEndCell As Range
        With Workbooks(Bureauplanner).Sheets("planning")
            Set PasteStartCell = .Cells(ThisProjectRow.Offset(-1, 0).Row, CurrentWeekBureauplanner.Column)
            Set PasteEndCell = .Cells(ThisProjectRow.Row, CurrentWeekBureauplanner.Offset(0, 106).Column)
        End With

    Dim PasteRange As Range
        Set PasteRange = Range(PasteStartCell, PasteEndCell)

'|  Execute copy and paste
    PasteRange = Phasedata.Value

'|  Save and close the Bureauplanner
    With Workbooks(Bureauplanner)
        .Save
        .Close
    End With

'|  End of the Code
Exit Sub

'|  Error messages
Errormessage:
MsgBox ("Er is iets mis gegaan, controleer de code")

End Sub