Vba code to run faster

Hello,

Not much experience with writing macros and with help from some awesome forums and googling have put pieces together. Having issue running on my original file as data is huge. It takes atleast min to search a name and extract data.
Need help from experts to run below code faster and if possible combine below code.

My macro splits fullname and any other name seperated by ";" from drop down menu from column "C" from sheet(2.implementation) and copies to another sheet (4. contact) in column D and E from row 60.

And from sheet (4. contact) row 60 column D and E extracts clients details from another sheet (contact) throu Macro (extractdata) to get information about client.

If any missing or changed information about a client , macro (fillmissingdata) is called to write any new information about client to sheet (Data) thru worksheet change event.

Rowclear Macro- clears contents any row if column D is empty in sheet (contact).
cpynpst Macro- is used to fill new client information to sheet(data)

Any suggestion will be much appreciated

Option Compare Text

Private Sub Worksheet_Activate()

With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
        .EnableEvents = False
End With
    
    Dim r As Range, a, i As Long, e, x
    
    With Sheets("2. Implementation")
        If .Range("c" & Rows.Count).End(xlUp).Row > 3 Then
            a = .Range("c3", .Range("c" & Rows.Count).End(xlUp)).Resize(, 2).Value
        End If
    End With
    If IsArray(a) Then
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                a(i, 1) = Application.Trim(a(i, 1))
                If a(i, 1) <> "" Then
                    For Each e In Split(a(i, 1), ";")
                        x = Split(Application.Trim(e))
                        ReDim Preserve x(1)
                        .Item(Trim$(e)) = x
                    Next
                End If
            Next
            a = Application.Index(.items, 0, 0): i = .Count
        End With
    End If
    With [d60:e60] ' Enters data from line 60
        .Resize(Rows.Count - .Row - 1).ClearContents
        If IsArray(a) Then
            .Resize(i).Value = a
        End If
    End With
        
        
    With Excel.Application
        .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
        .EnableEvents = True
End With

Call ExtractFromData
    Call RowClear
End Sub


Sub ExtractFromData() 'macro to pullinfo from data into contacts sheet

With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
        .EnableEvents = False
End With

Dim i As Long
Dim j As Long

Sheet4LastRow = Worksheets("4. Contact").Range("D" & Rows.Count).End(xlUp).Row
sheet5LastRow = Worksheets("Data").Range("A" & Rows.Count).End(xlUp).Row

    For j = 44 To Sheet4LastRow
        For i = 3 To sheet5LastRow
            If Worksheets("4. Contact").Cells(j, 4).Value = Worksheets("Data").Cells(i, 1).Value _
                And Worksheets("4. Contact").Cells(j, 5).Value = Worksheets("Data").Cells(i, 2).Value Then
                Worksheets("4. Contact").Cells(j, 1).Value = Worksheets("Data").Cells(i, 3).Value
                Worksheets("4. Contact").Cells(j, 3).Value = Worksheets("Data").Cells(i, 4).Value
                Worksheets("4. Contact").Cells(j, 6).Value = Worksheets("Data").Cells(i, 5).Value
                Worksheets("4. Contact").Cells(j, 7).Value = Worksheets("Data").Cells(i, 6).Value
                Worksheets("4. Contact").Cells(j, 8).Value = Worksheets("Data").Cells(i, 8).Value

            Else
            End If
    Next i
Next j
    With Excel.Application
        .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
        .EnableEvents = True
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
        .EnableEvents = False
End With


If Not Intersect(Target, Range("F60:H107")) Is Nothing Then
End If
Call FillMissingData

With Excel.Application
        .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
        .EnableEvents = True
End With
    
End Sub

Sub FillMissingData() 'macro to Fill and Missing informoation into Data sheet from contact sheet

With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
        .EnableEvents = False
End With

Dim i As Long
Dim j As Long

Sheet4LastRow = Worksheets("4. Contact").Range("D" & Rows.Count).End(xlUp).Row
sheet5LastRow = Worksheets("Data").Range("A" & Rows.Count).End(xlUp).Row

    For j = 60 To Sheet4LastRow
        For i = 3 To sheet5LastRow
            If Worksheets("Data").Cells(i, 1).Value = Worksheets("4. Contact").Cells(j, 4).Value _
                And Worksheets("Data").Cells(i, 2).Value = Worksheets("4. Contact").Cells(j, 5).Value Then
                Worksheets("Data").Cells(i, 3).Value = Worksheets("4. Contact").Cells(j, 1).Value
                Worksheets("Data").Cells(i, 4).Value = Worksheets("4. Contact").Cells(j, 3).Value
                Worksheets("Data").Cells(i, 5).Value = Worksheets("4. Contact").Cells(j, 6).Value
                Worksheets("Data").Cells(i, 6).Value = Worksheets("4. Contact").Cells(j, 7).Value
                Worksheets("Data").Cells(i, 8).Value = Worksheets("4. Contact").Cells(j, 8).Value

            Else
            End If
    Next i
Next j

   With Excel.Application
        .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
        .EnableEvents = True
End With

End Sub

Sub RowClear() 'Clear Row if column D is empty

    Dim Firstrow As Long
    Dim lastrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    

Firstrow = 60
lastrow = 107


    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    With ActiveSheet

        'We select the sheet so we can change the window view
        .Select

        'If you are in Page Break Preview Or Page Layout view go
        'back to normal view, we do this for speed
        ' ViewMode = ActiveWindow.View
       ' ActiveWindow.View = xlNormalView

        'Turn off Page Breaks, we do this for speed
        '.DisplayPageBreaks = False

        'Set the first and last row to loop through
        Firstrow = 60
        lastrow = 107

        'We loop from Lastrow to Firstrow (bottom to top)
        For Lrow = lastrow To Firstrow Step -1

            'We check the values in the D column in this example
            With .Cells(Lrow, "D")

                If Not IsError(.Value) Then

                    If .Value = "" Then .EntireRow.ClearContents
                    'This will delete each row with the Value "empty"
                    'in Column D, case sensitive.

                End If

            End With

        Next Lrow

    End With

'    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With

End Sub



Sub cpynpst() ' Macro to add new data into Data sheet from (Contact sheet)

With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
        .EnableEvents = False
        
        End With

Dim sh4 As Worksheet, sh5 As Worksheet, lr As Long, rng As Range
Set sh4 = Sheets("4. Contact")
Set sh5 = Sheets("Data")
' lr = sh4.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh4.Range("a57:h57")
rng.EntireRow.Copy sh5.Cells(Rows.Count, 1).End(xlUp)(2)

With Excel.Application
        .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
        .EnableEvents = True
End With

    
End Sub