Code running slowly

All,

I have the code below designed to remove any picture objects, reset the font, and delete some blank cells and some columns. I have it looping in a folder with about 52k workbooks that need to be modified. Unlike my other macros,this one has been running for 3 days and still isn't done. Is there something in the code that could be causing delays? The sheets are less than 100k in size each.

Thanks!

Sub New_Clean()
'
' Macro2 Macro
'
Dim PathName As String
Dim FileName As String
Dim CurrentWB As Workbook
Dim Pic As Object

PathName = "C:\BoxScoreTest\"
FileName = Dir(PathName & "*.xls")
Do While FileName <> ""
  Set CurrentWB = Workbooks.Open(PathName & FileName)
  With CurrentWB.ActiveSheet
    .Rows("1:30").Delete Shift:=xlUp
 With .UsedRange.Font
      .Name = "Verdana"
      .Size = 10
      .Strikethrough = False
      .Superscript = False
      .Subscript = False
      .OutlineFont = False
      .Shadow = False
      .TintAndShade = 0
      .ThemeFont = xlThemeFontNone
      .ColorIndex = xlAutomatic
          
    ActiveWindow.SmallScroll Down:=-120
    Range("A1:BR500").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlToLeft
 
    Columns("I:BX").Select
    Selection.Delete Shift:=xlToLeft
    
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

For Each Pic In ActiveSheet.Pictures
Pic.Delete
Next Pic

    End With
    End With

CurrentWB.Close True
FileName = Dir()

Loop
End Sub

Yup, that's running much faster. Thanks!