How to auto copy

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("B:B")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub

If Target.Value = "*" Then Target.EntireRow.Copy Sheets("Follow up").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Target.Select
End Sub

Sub Copy()
    Dim ws As Worksheet
    Dim dSht As Worksheet
    Dim dRow As Long
    Dim lRow As Long
    Set dSht = Worksheets("Sheet2")
    Application.ScreenUpdating = False
    dRow = dSht.Range("A" & Rows.Count).End(xlUp).Row + 1
    For Each ws In Worksheets
        A = ws.Name
Select Case ws.Name
    Case "Sheet1":
    With ws
    .UsedRange.AutoFilter Field:=1, Criteria1:="*"
    .UsedRange.Offset(1, 0).Copy
     dSht.Cells(dRow, 1).PasteSpecial xlPasteValues
    .UsedRange.Offset(1, 0).SpecialCells(12).EntireRow.Delete
    .UsedRange.AutoFilter
    dRow = dSht.Range("A" & Rows.Count).End(xlUp).Row + 1
End With
End Select
    Next ws
Application.ScreenUpdating = True
Beep
MsgBox "Data transfer complete", vbExclamation
End Sub

Sub Copy()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "Summary" Then GoTo NextSheet
    
    ws.Select
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
    For Each cell In Range("A2:A" & lRow)
        If cell.Value = "*" Then
            Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).Copy
            Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).ClearContents
        End If
    Next cell

    ws.UsedRange.Sort key1:=Range("A1"), Header:=xlYes

NextSheet:
Next ws

Sheets("Summary").Select

Application.ScreenUpdating = True

Beep

MsgBox "Data transfer complete", vbExclamation
End Sub