Macro Correction Needed to Remove Text and blanks

All,

I need a little help. Here's the code I have so far to move from the Before to After sheets I've attached. As you can see, I'm still new to this and I'm no where near correct. Can you help out? I need to get from Before to After.

Sub BoxScore_Convert()
'
' NBA BoxScore Upload Prep
'
Dim PathName As String
Dim NewBook As String
Dim CurrentWB As Workbook
Dim Pic As Object
Dim bottomA As Integer
Dim rRow1 As Long
Dim rRow2 As Long
Dim rRow3 As Long
Dim Officials As String
Dim TeamTotal As String
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim FindString As String
Dim textCounter As Long
Dim x As Long

PathName = "C:\BoxScoreTest\"
NewBook = Dir(PathName & "*.xls")
Do While NewBook <> ""
  
' Set font and remove blanks
  Set CurrentWB = Workbooks.Open(PathName & NewBook, 0)
    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
          
    bottomA = Range("A" & Rows.Count).End(xlUp).Row
    Officials = "Officials:"
    TeamTotal = "Team Totals"
    FindString = "Advanced Box Score Stats"
    textCounter = Application.CountIf(ActiveSheet.Range("A:E"), "Advanced Box Score Stats")
    For x = 1 To textCounter
        If Trim(FindString) <> "" Then
            With Sheets("Sheet1").Range("A:E")
                Set Rng1 = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                If Not Rng1 Is Nothing Then
                    rRow1 = Rng1.Row
                End If
            End With
            With Sheets("Sheet1").Range("A" & rRow1 & ":A" & bottomA)
                Set Rng2 = .Find(What:=TeamTotal, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                If Not Rng2 Is Nothing Then
                    rRow2 = Rng2.Row
                End If
            End With
        End If
        Range(rRow1 & ":" & rRow2).EntireRow.Delete
    Next x
    
    With Sheets("Sheet1").Range("A1:A" & bottomA)
        Set Rng3 = .Find(What:=Officials, _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
        If Not Rng3 Is Nothing Then
            rRow3 = Rng3.Row
        End If
        Range(rRow3 & ":" & rRow3 + 20).EntireRow.Delete
 
For Each Pic In ActiveSheet.Pictures
Pic.Delete
Next Pic

Range("A1:BZ500").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
Range("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A:A").Value = Range("B:B").Value
Range("D6").Select

    End With
    End With
    End With

CurrentWB.Close True
NewBook = Dir()

Loop
End Sub

]

201106120MIA-After.xls201106120MIA-Before.xls