[Spirosgr]

Αντιγράψτε τον κώδικα, σε μια module.
Αν η έκφραση "Option Explicit" υπάρχει ήδη να μην την αντιγράψετε δεύτερη φορά.
Χρησιμοποιήθηκαν, οι κωδικές ονομασίες φύλλων (πχ Sheet1)
Ο κώδικας προσαρμόστηκε, για να μην επιρεάζεται από συγχωνευμένα κελιά.

Αν υπάρξουν ΑΜ στο φύλλο 5,
που δεν υπάρχουν στα 1 και 3,
«μαζεύονται» σε νέο φύλλο,
με όνομα "NotExists" που δημιουργεί ο κώδικας,
στο τέλος των υφιστάμενων φύλλων του βιβλίου.

Το βιβλίο, πρέπει να είναι σε μορφές .xls - .xlsm - .xlsb για να μπορεί να εκτελέσει κώδικα.

Option Explicit
Const handicap5 As Byte = 11 'Επάνω κενές σειρές φύλλου 5
Const handicap1or3 As Byte = 8  'Επάνω κενές σειρές φύλλων 2 και 3

'---------------------------------------------------------------------------

Sub transfer()
    Application.ScreenUpdating = False

    'Διαγράφει φύλλο με όνομα NotExists (Αν Υπάρχει)
    Dim WSH As Worksheet
    Application.DisplayAlerts = False
    For Each WSH In ThisWorkbook.Worksheets
        If WSH.Name = "NotExists" Then WSH.Delete
    Next WSH
    Application.DisplayAlerts = True

    'Βάζει νέο φύλλο με όνομα NotExists (1α)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets.Add(After:= _
                                     ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "NotExists"
    ws.Range("a1").Value = "ΑΜ που δεν υπάρχουν"

    'Σετάρισμα & καθαρισμός περιοχών
    '1. Αφετηρία
    Dim Lr5 As Long
    Lr5 = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row

    '2. Προορισμοί
    Dim Lr1 As Long
    Lr1 = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row

    Sheet1.Range("u9:z" & Lr1).ClearContents

    Dim Lr3 As Long
    Lr3 = Sheet3.Cells(Rows.Count, 2).End(xlUp).Row

    Sheet3.Range("u9:z" & Lr1).ClearContents

    Dim Rng1 As Range, Rng3 As Range
    Set Rng1 = Sheet1.Range("b9:b" & Lr1)
    Set Rng3 = Sheet3.Range("b9:b" & Lr3)

    Dim i As Long
    For i = handicap5 To Lr5

        Dim iVL As Double
        iVL = Val(Sheet5.Range("a" & i).Value)

        'Ψάχνει κοινούς ΑΜ στα φύλλα προορισμού
        Dim Mtch1 As Long, Mtch3 As Long
        On Error Resume Next
        Mtch1 = 0
        Mtch1 = Application.WorksheetFunction.Match(iVL, Rng1, 0)
        Mtch3 = 0
        Mtch3 = Application.WorksheetFunction.Match(iVL, Rng3, 0)

        'Αν βρεθεί ΑΜ χωρίς προορισμό (1β)
        If Mtch1 = 0 And Mtch3 = 0 Then

            'Τοποθετείται στο νέο φύλλο (μαζί με ημερομηνία = σήμερα)
            Dim Nr As Long
            Nr = Sheets("NotExists").Cells(Rows.Count, 1).End(xlUp).Row + 1

            Sheets("NotExists").Range("a" & Nr).Format = "@"
            Sheets("NotExists").Range("a" & Nr).Value = iVL
            Sheets("NotExists").Range("b" & Nr).Value = Format(Date, "dd/mmm/yyyy")

            With Sheets("NotExists").Columns("a:b")
                .WrapText = False
                .ShrinkToFit = False
                .MergeCells = False
                .EntireColumn.AutoFit
            End With
        End If

        'Μεταφορά δεδομένων στους προορισμούς τους
        If Mtch1 <> 0 Then
            Sheet1.Cells(Mtch1 + handicap1or3, 21).Value = Sheet5.Range("h" & i).Value
            Sheet1.Cells(Mtch1 + handicap1or3, 22).Value = Sheet5.Range("i" & i).Value
            Sheet1.Cells(Mtch1 + handicap1or3, 23).Value = Sheet5.Range("j" & i).Value
            Sheet1.Cells(Mtch1 + handicap1or3, 24).Value = Sheet5.Range("k" & i).Value
            Sheet1.Cells(Mtch1 + handicap1or3, 25).Value = Sheet5.Range("m" & i).Value
            Sheet1.Cells(Mtch1 + handicap1or3, 26).Value = Sheet5.Range("o" & i).Value
        End If

        If Mtch3 <> 0 Then
            Sheet3.Cells(Mtch3 + handicap1or3, 21).Value = Sheet5.Range("h" & i).Value
            Sheet3.Cells(Mtch3 + handicap1or3, 22).Value = Sheet5.Range("i" & i).Value
            Sheet3.Cells(Mtch3 + handicap1or3, 23).Value = Sheet5.Range("j" & i).Value
            Sheet3.Cells(Mtch3 + handicap1or3, 24).Value = Sheet5.Range("k" & i).Value
            Sheet3.Cells(Mtch3 + handicap1or3, 25).Value = Sheet5.Range("m" & i).Value
            Sheet3.Cells(Mtch3 + handicap1or3, 26).Value = Sheet5.Range("o" & i).Value
        End If

    Next i
End Sub