Excel VBA - уменьшить время выполнения для выполнения действия вырезания

Question

Я надеюсь, что у кого-то есть способ значительно сократить время, необходимое для выполнения приведенного ниже кода. У меня есть лист с кодом для открытия файла и импорта данных из этого файла. Там нет проблем. Приведенный ниже код будет затем искать в столбце A имя конкретного человека, когда имя этого человека будет найдено, он вырезает и вставляет эту строку в соответствующий лист этих лиц. Этот код занимает минуты, чтобы выполнить. В каждой строке всегда будут данные в столбцах A, B и C. Столбцы D, E, F могут содержать или не содержать даты в них. В настоящее время файл импорта имеет около 1200 строк и будет увеличиваться. В любом случае, чтобы повысить эффективность этого действия?

Private Sub CommandButton1_Click()
    Dim sh As Worksheet, ws As Worksheet
    Dim rws As Long, rng As Range, c As Range

    Set sh = Worksheets("data")
    Set aa = Worksheets("aamory")
    Set bg = Worksheets("bglesing")
    Set da = Worksheets("damory")
    Set Db = Worksheets("dbutzer")
    Set dd = Worksheets("ddelnero")
    Set dm = Worksheets("dmacmaster")
    Set er = Worksheets("erose")
    Set gr = Worksheets("gragonese")
    Set jg = Worksheets("jgabbard")
    Set lw = Worksheets("lwhite")
    Set kc = Worksheets("kcarter")
    Set lw = Worksheets("lwhite")
    Set mb = Worksheets("mbrooks")
    Set rg = Worksheets("rgallese")
    Set sp = Worksheets("spolk")
    Set sb = Worksheets("sbrooks")

    With sh
        rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set rng = .Range(.Cells(1, 1), .Cells(rws, 1))
    End With

    For Each c In rng.Cells

        If c = "aamory" Then
            c.EntireRow.Cut Destination:=aa.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "bglesing" Then
            c.EntireRow.Cut Destination:=bg.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "damory" Then
            c.EntireRow.Cut Destination:=da.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "dbutzer" Then
            c.EntireRow.Cut Destination:=Db.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "ddelnero" Then
            c.EntireRow.Cut Destination:=dd.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "dmacmaster" Then
            c.EntireRow.Cut Destination:=dm.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "erose" Then
            c.EntireRow.Cut Destination:=er.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "gragonese" Then
            c.EntireRow.Cut Destination:=gr.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "jgabbard" Then
            c.EntireRow.Cut Destination:=jg.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "lwhite" Then
            c.EntireRow.Cut Destination:=lw.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "kcarter" Then
            c.EntireRow.Cut Destination:=kc.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "mbrooks" Then
            c.EntireRow.Cut Destination:=mb.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "rgallese" Then
            c.EntireRow.Cut Destination:=rg.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "spolk" Then
            c.EntireRow.Cut Destination:=sp.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
        If c = "sbrooks" Then
            c.EntireRow.Cut Destination:=sb.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If

       Next c
Application.ScreenUpdating = True
End Sub