Copy and Paste row under specific column Heading VBA

Right now I have code that is copying and pasting rows where the column "A" numbers on the "Data" sheet are found on the "Exceptions" sheet in columns A,B or C.

As of now they are pasting as last rows on the sheet, however Im wondering if theres a way to modify my code so they paste under the corresponding header from the "Exceptions" sheet.

Example 1: Numbers 456, 678 rows should be copied under the "A" Description header on the "Data" sheet since 456, 678 are labeled as "Move to A" on the "Exceptions" sheet.

Example 2: Number 123 row should be copied under the "B" Description header since labeled "Move to B" on "Exceptions" sheet

Example 3: Numbers 345 should be copied under the "C" description header on "Data" sheet since labled "Move to C" on the "Exceptions" sheet.

Sub CopyRow()

Dim lastRow As Long
Dim lRow As Long
Dim Data As String
Dim Exceptions As String

Data = "Data" 'Sheet name
Exceptions = "Exceptions" 'Sheet name
lastRow = Sheets(Data).Range("A" & Rows.Count).End(xlUp).Row

   For lRow = 2 To lastRow 'Loop through all rows

If Application.CountIf(Sheets(Exceptions).Columns("A"), Sheets(Data).Cells(lRow, "A").Value2) > 0 Then
 Sheets(Data).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value = Sheets(Data).Rows(lRow).Value2
 End If
If Application.CountIf(Sheets(Exceptions).Columns("B"), Sheets(Data).Cells(lRow, "A").Value2) > 0 Then
 Sheets(Data).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value = Sheets(Data).Rows(lRow).Value2
End If
If Application.CountIf(Sheets(Exceptions).Columns("C"), Sheets(Data).Cells(lRow, "A").Value2) > 0 Then
 Sheets(Data).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value = Sheets(Data).Rows(lRow).Value2
End If

Next lRow

End Sub

Data Sheet (Before)

Exceptions Sheet

Data Sheet (After)

[

Feels a bit clunky, but try this out:

Sub MoveRows()

    Dim wsD As Worksheet, wsE As Worksheet, r As Long
    Dim rngData As Range, rngEx As Range, mH, mR, col As Long, hdr, v
    Dim rngCopy As Range, lr As Long, addr
    
    Set wsD = ThisWorkbook.Worksheets("Data")
    Set wsE = ThisWorkbook.Worksheets("Exceptions")
    
    Set rngData = wsD.Range("A2:B" & wsD.Cells(Rows.Count, "A").End(xlUp).Row)
    
    For col = 1 To 3  'loop the columns on the exceptions sheet
        lr = wsE.Cells(Rows.Count, col).End(xlUp).Row
        If lr > 1 Then
            'get the section header and find on "Data"
            hdr = Replace(wsE.Cells(1, col).Value, "Move to ", "")
            mH = Application.Match(hdr, rngData.Columns(2), 0)
            
            If Not IsError(mH) Then 'matched the header?
                For r = 2 To lr
                    v = wsE.Cells(r, col).Value
                    mR = Application.Match(v, rngData.Columns(1), 0)
                    If Not IsError(mR) Then
                        Set rngCopy = rngData.Rows(mR)
                        rngData.Rows(mH + 1).Insert       'add row below header
                        rngCopy.Copy rngData.Rows(mH + 1) 'copy values
                        rngCopy.Delete shift:=xlShiftUp   'delete source row
                    Else
                        'value was not matched
                        MsgBox "Value '" & v & "' not found on Data sheet!"
                    End If
                Next r
            Else
                'header not matched
                MsgBox "Header '" & hdr & "' not found on data sheet!"
            End If
        End If
    Next col
End Sub