使用自动筛选

Option Explicit

Sub Disperse_Data()

    Dim wb As Workbook, wsData As Worksheet, ws As Worksheet
    Dim rngData As Range, n As Long, lastrow As Long
    Dim s As String, c As Long, r as Long
    Dim t0 As Single: t0 = Timer
    
    ' check selection
    If Selection.Column <> 4 Then
        MsgBox "Select column D", vbCritical
        Exit Sub
    ElseIf vbNo = MsgBox(Selection.Rows.Count & " rows selected, OK", _
        vbYesNo, "Confirm") Then
        Exit Sub
    End If
    
    Set wsData = Selection.Parent
    With wsData
        Set rngData = Intersect(Selection, .UsedRange)
        ' last column
        c = .UsedRange.Column + .UsedRange.Columns.Count - 1
        'MsgBox rngData.Address & " " & c
    End With
    
    ' copy
   Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    For Each ws In wb.Sheets
        If ws.Name Like "SU4##" Then
            s = Right(ws.Name, 3)
            'ws.Cells.Clear
            r = 1 + ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
            With rngData.Offset(, -3).Resize(, c)
                .AutoFilter 4, s
                .SpecialCells(xlCellTypeVisible).Copy _
                  ws.Range("A" & r)
                .AutoFilter
                n = n + 1
            End With
            ' remove header
            If ws.Range("D" & r) <> s Then ws.Rows(r).Delete
        End If
    Next
    Application.ScreenUpdating = True
    
    MsgBox n & " sheets updated", vbInformation, _
           Format(Timer - t0, "0.0 secs")
    
End Sub