Can my VBA code run faster?

[Ramballah]

Hi everyone,

I have this code where it works exactly like how I want it to.
Sort on ascending (A-Z)
Do the code
Sort on descending (Z-A)

But after having the sort's in there (which I need) it became really slow
Is it possible to make this faster with cleaner coding etc? If so how (P.S) I don't know how to write macro this is something someone else made for me.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Rw As Long, MaxWinRow As Long, MaxLoseRow As Long
  If Target.Address(0, 0) = "D1" And Len(Range("D1")) > 0 Then
    ActiveWorkbook.Worksheets("Sheet2").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.EnableEvents = False
    Rw = Cells(Rows.Count, "A").End(xlUp).Row + 1
    MaxWinRow = Evaluate(Replace("MAX(IF((E3:E#=""Win"")*(H3:H#=""Me""),ROW(E3:E#)))", "#", Rw - 1))
    MaxLoseRow = Evaluate(Replace("MAX(IF((E3:E#=""Lose"")*(H3:H#=""Me""),ROW(E3:E#)))", "#", Rw - 1))
    Cells(Rw, "A").Value = Val(Cells(Rw - 1, "A")) + 1
    Cells(Rw, "C").Resize(, 2).Value = Split([SUBSTITUTE(SUBSTITUTE(LOWER(B1),"t","Tails"),"h","Heads")])
    Cells(Rw, "C").Value = Cells(Rw, "C").Value
    Cells(Rw, "C").NumberFormat = "0"
    Cells(Rw, "E").Value = [PROPER(C1)]
    Cells(Rw, "F").Value = [IF(C1="win",IF(RIGHT(B1)="h","Heads","Tails"),IF(RIGHT(B1)="h","Tails","Heads"))]
    Cells(Rw, "G").Value = IIf([D1="me"], IIf(Cells(Rw, "E").Value = "Lose", -1, 1) * Cells(Rw, "c").Value, "")
    Cells(Rw, "G").NumberFormat = "\$ 0;\$ -0"
    Cells(Rw, "H").Value = [PROPER(D1)]
    If [AND(C1 = "win",D1 = "me")] Then
      If MaxWinRow Then
        Cells(Rw, "B").Value = 1 - Cells(MaxWinRow, "B") * (MaxWinRow > MaxLoseRow)
      Else
        Cells(Rw, "B").Value = 1
      End If
    End If
    Cells(Rw, "A").Resize(, 8).Font.Bold = True
    [B1:D1] = ""
    Range("B1").Select
    Application.EnableEvents = True
    ActiveWorkbook.Worksheets("Sheet2").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("A2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  End If
End Sub

Thanks in advance,
Ramballah

 

[Crystalyzer]

Insert Application.ScreenUpdating = False at the beginning and Application.ScreenUpdating = True at the end. Should help some.

 

[lrobbo314]

I would also add 'Application.EnableEvents = False' at the beginning and 'Application.EnableEvents = True' at the end.

 

[Ramballah]

Both of you thank you a lot !

 

[GWteB]

I think that the following may also have a positive influence ...

' AutoFilter
Application.Calculation = xlCalculationManual
'
'  the part in which the value of some cells are changed
' 
Application.Calculation = xlCalculationAutomatic
Application.Calculate
' AutoFilter