VBA Comapre, Match & Copy Data

Hi, I wonder whether someone may be able to help me please.

With some help along the way, I've put together the following code which compares two lists, and where a match is found, copies the associated data from columns F:H which is this part of the my script

For ac = 2 To 4

on the "All Projects" sheet and pastes this information to columns D:F on the "In Flight Projects" sheet.

Sub AdditionalProjectsListData()
    
    Dim Dic As Object
    Dim Dn As Range
    Dim n As Long
    Dim rng As Range
    
    With Sheets("All Projects")
        Set rng = .Range(.Range("C5"), .Range("C" & Rows.count).End(xlUp))
    End With
    
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For Each Dn In rng
        Set Dic(Dn.Value) = Dn
    Next
    
    With Sheets("In Flight Projects")
        Set rng = .Range(.Range("B5"), .Range("B" & Rows.count).End(xlUp))
    End With
    
    For Each Dn In rng
        If Dic.Exists(Dn.Value) Then
            For ac = 2 To 4
                If ac > 2 Then Dn.Offset(, ac).NumberFormat = "dd/mm/yyyy"
                Dn.Offset(, ac) = Dic.Item(Dn.Value).Offset(, ac + 1)
                Next ac
            End If
        Next Dn
End Sub

The code works fine, but I'd now like to change this which is where I'm having difficulty.

What I'm trying to do is only copy from columns F and H on the "All Projects" sheet and paste this into columns D and F on the "In Flight Projects" sheet.

I just wondered whether someone could possibly look at this please and offer some guidance on how I may go about achceiving this.

Many thanks and kind regards

Sub MG27Oct32am()
Dim Rng As Range, Dn As Range, n As Long
Dim Dic As Object
With Sheets("Projects List")
Set Rng = .Range(.Range("C5"), .Range("C" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
    For Each Dn In Rng
        Set Dic(Dn.Value) = Dn
    Next

With Sheets("In flight")
    Set Rng = .Range(.Range("B5"), .Range("B" & Rows.Count).End(xlUp))
End With
For Each Dn In Rng
    If Dic.exists(Dn.Value) Then

             Dn.Offset(, 2) = Dic.Item(Dn.Value).Offset(, 2 + 1)
             Dn.Offset(, 4) = Dic.Item(Dn.Value).Offset(, 4 + 1)
             Dn.Offset(, 4).NumberFormat = "mmm yy"
    End If
Next Dn
End Sub

Hi @AB33, thank you very much for taking the time to reply to my post and for the solutino, which workls beautifully.

May I ask, if it's not too much trouble, if you could possibly add some very quick notes so that I can understand the code, because I am wanting to increase my VBA knowledge.

Many thanks and kind regards

Chris,
I have amended my own code too, but not commented on it as you may find Mick's code easier to understand.

Hi AB33, thank you very much for takign the time to put this together, it is greatly appreciated.

All the best and kind regards