Help speeding up large macro

[kirbyfez]

Hi community,

I wrote this macro today but it's really taking way to long to run and I'm sure certain changes can be made to speed up the process.

I've tried reducing the selecting and so on but sadly in vain.

Would someone mind having a look below and pointing me in the right direction?

Please let me know if you need any more information or walkthrough of the code.

Sub Formatting()
Application.ScreenUpdating = False
Range("a3:A5").EntireRow.Delete
Range("a3").Value = "Analyst"
Range("b3").Value = "Time Start"
Range("c3").Value = "Time End"
Range("d3").Value = "Handling Time"
Range("e3").Value = "Time Before Answer"
Range("f3").Value = "Total Durnation"
Range("g3").Value = "Disconnection Source"
Range("a4").Select
Row = 4
Col = 1
LastRow = Range("A300000").End(xlUp).Row
Do Until Cells(Row, Col).Value = Empty
If InStr(1, Cells(Row, Col).Offset(0, 0).Value, "Contact ID") > 0 Then
Range("a1").Value = (LastRow / 10) - Row
'Agent Name
Cells(Row, Col).Value = Cells.Find(What:="Agent Name", After:=Cells(Row, Col), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Value

Cells(Row, Col).Value = Right(Cells(Row, Col).Offset(0, 0), Len(Cells(Row, Col).Offset(0, 0)) - 17)
Col = Col + 1
'Time Start


Cells(Row, Col).Value = Cells.Find(What:="Contact Originated", After:=Cells(Row, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Value

Cells(Row, Col).Offset(0, 0).Value = Right(Cells(Row, Col).Offset(0, 0), Len(Cells(Row, Col).Offset(0, 0)) - 20)
Col = Col + 1


'Time End
Cells(Row, Col).Value = Cells.Find(What:="End Time", After:=Cells(Row, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Value



Cells(Row, Col).Offset(0, 0).Value = Right(Cells(Row, Col).Offset(0, 0), Len(Cells(Row, Col).Offset(0, 0)) - 10)
Col = Col + 1


'Handling Time
Cells(Row, Col).Value = Cells.Find(What:="Handling Time", After:=Cells(Row, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Value

Cells(Row, Col).Offset(0, 0).Value = Right(Cells(Row, Col).Offset(0, 0), Len(Cells(Row, Col).Offset(0, 0)) - 15)
Col = Col + 1


'Time Before Answer
Cells(Row, Col).Value = Cells.Find(What:="Skillset Delay", After:=Cells(Row, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Value

Cells(Row, Col).Offset(0, 0).Value = Right(Cells(Row, Col).Offset(0, 0), Len(Cells(Row, Col).Offset(0, 0)) - 16)
Col = Col + 1


' Total Durnation
Cells(Row, Col).Value = Cells.Find(What:="Duration:", After:=Cells(Row, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Value

Cells(Row, Col).Offset(0, 0).Value = Right(Cells(Row, Col).Offset(0, 0), Len(Cells(Row, Col).Offset(0, 0)) - 10)
Col = Col + 1


' Disconnection Source
Cells(Row, Col).Value = Cells.Find(What:="Disconnect Source:", After:=Cells(Row, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Value
Cells(Row, Col).Offset(0, 0).Value = Right(Cells(Row, Col).Offset(0, 0), Len(Cells(Row, Col).Offset(0, 0)) - 19)


Col = 1


Do Until Cells(Row, Col).Offset(1, 0).Value = Empty
Cells(Row, Col).Offset(1, 0).EntireRow.Delete
Loop


Else
End If
Cells(Row, Col).Offset(1, 0).EntireRow.Delete
Row = Row + 1
Loop
Cells(Row, Col).EntireRow.Delete
Cells(Row, Col).EntireRow.Delete
Cells(Row, Col).EntireRow.Delete
Cells(Row, Col).EntireRow.Delete
Cells(Row, Col).EntireRow.Delete
Cells(Row, Col).EntireRow.Delete
Cells(Row, Col).EntireRow.Delete





Range("a1").EntireRow.Delete
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Range("A2").Select
ActiveCell.FormulaR1C1 = "Call Number"
Range("A3").Select
ActiveCell.FormulaR1C1 = "1"
Range("A4").Select
ActiveCell.FormulaR1C1 = "2"
Range("A5").Select
ActiveCell.FormulaR1C1 = "3"
LastRow = Range("b4").End(xlDown).Row
Range("A3:A5").Select


Selection.AutoFill Destination:=Range("A3:A" & LastRow)


Range("a1").Select


Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Rows("2:2").Select
Selection.Font.Bold = True
Columns("C:C").Select
Range("C2").Activate
Selection.Font.Bold = False
Range("B3").Select


Rows("2:2").Select
Selection.Font.Bold = True

Range("D3:E300000").Select
Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("D3").Select
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("D2").Select
ActiveSheet.Paste
Range("D2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Date"
Range("d2").EntireColumn.NumberFormat = "m/d/yyyy"
Range("A1").Value = "Call by Call Summary"
Range("b1").ClearContents


Range("A1:J1").Select
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With

Range("A2").EntireRow.Select

Range("d2:D60000").Copy
Range("d2").Select
ActiveSheet.Paste


Selection.AutoFilter

Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub