Macro to move rows in excel automatically

Sub test()
    Dim r As Range, cfind As Range, j As Integer, add As String
    Dim k As Integer, m As Integer, c As Range
    Application.ScreenUpdating = False
    Worksheets("sheet1").Cells.Clear
    Worksheets("sheet2").Cells.Copy Worksheets("sheet1").Range("A1")

    Worksheets("sheet1").Activate

    Set r = Range(Range("a1"), Range("a1").End(xlDown))
    r.EntireColumn.AutoFit
    For Each c In ActiveSheet.UsedRange
        If c = "" Then c = "X"
    Next c

    Set cfind = r.Cells.Find(what:="event", lookat:=xlPart)
    If Not cfind Is Nothing Then
        add = cfind.Address
        j = cfind.Row
        Set cfind = r.Cells.FindNext(cfind)
        k = cfind.Row
        For m = j + 1 To k - 1
            Range(Cells(m, "B"), Cells(m, "B").End(xlToRight)).Cut Cells(j, "A").End(xlToRight).Offset(0, 1)
        Next m
    End If
    Do
        j = k
        Set cfind = r.Cells.FindNext(cfind)
        If cfind Is Nothing Then Exit Do
        If cfind.Address = add Then Exit Do
        k = cfind.Row
        For m = j + 1 To k - 1
            Range(Cells(m, "B"), Cells(m, "B").End(xlToRight)).Cut Cells(j, "A").End(xlToRight).Offset(0, 1)
        Next m
    Loop
    j = Range("a1").End(xlDown).Row
    'MsgBox j

    For k = j To 2 Step -1
        'MsgBox Cells(k, "A").Address
        If InStr(Cells(k, "A"), "event") = 0 Then Cells(k, "A").EntireRow.Delete
    Next k
    MsgBox "macro over"
    Application.ScreenUpdating = True
End Sub