Cleaning up My Table

[AArcher2]

I receive an excel report with a very interesting formating and in trying automate the clean up process of this table. I created the following code to remove the extra headers in the table, the code removes all but one header that starts with "*000*". Here is the code i have:

Sub RemoveHeaders()

    Const HdrText As String = "*Grade Name*"
    Const HdrKeepRow As Long = 1
    Dim c As Range
    Dim lr As Long


    Application.ScreenUpdating = False


    lr = Range("A" & Rows.Count).End(xlUp).Row
    
    With Range("A" & HdrKeepRow & ":A" & lr)
    Set c = .Find(HdrText, LookIn:=xlValues, SearchDirection:=xlNext)


    If Not c Is Nothing And c.Row <> HdrKeepRow Then


        Do
        c.Resize(1).EntireRow.Delete
        Set c = .Find(HdrText, LookIn:=xlValues, SearchDirection:=xlNext)
            
            Loop While Not c Is Nothing And c.Row <> HdrKeepRow
    End If
    End With
    
    Const HdrText1 As String = "*000*"
    Const HdrKeepRow1 As Long = 1
    Dim c1 As Range
    Dim lr1 As Long


    Application.ScreenUpdating = False


    lr1 = Range("A" & Rows.Count).End(xlUp).Row
    
    With Range("A" & HdrKeepRow & ":A" & lr)
    Set c1 = .Find(HdrText1, LookIn:=xlValues, SearchDirection:=xlNext)


    If Not c1 Is Nothing And c.Row <> HdrKeepRow1 Then


        Do
        c.Resize(1).EntireRow.Delete
        Set c1 = .Find(HdrText1, LookIn:=xlValues, SearchDirection:=xlNext)
            
            Loop While Not c1 Is Nothing And c1.Row <> HdrKeepRow1
    End If
    End With
  
  Const HdrText2 As String = "*999*"
    Const HdrKeepRow2 As Long = 1
    Dim c2 As Range
    Dim lr2 As Long


    Application.ScreenUpdating = False


    lr2 = Range("A" & Rows.Count).End(xlUp).Row
    
    With Range("A" & HdrKeepRow2 & ":A" & lr)
    Set c2 = .Find(HdrText2, LookIn:=xlValues, SearchDirection:=xlNext)


    If Not c2 Is Nothing And c.Row <> HdrKeepRow Then


        Do
        c.Resize(1).EntireRow.Delete
        Set c2 = .Find(HdrText, LookIn:=xlValues, SearchDirection:=xlNext)
            
            Loop While Not c2 Is Nothing And c2.Row <> HdrKeepRow2
    End If
    End With




Application.ScreenUpdating = True


End Sub


Sub Cleanup()


    Dim arrCols, shtSrc As Worksheet, rngDest As Range, hdr, pn


    arrCols = Array("000000000, L", "000000000, P", "0004AFSQ, L", "0004AFSQ, P", "0004AFSQ, S", "0007AFSQ, L", "0007AFSQ, P", "0007AFSQ, S", "0008AFSQ, L", "0008AFSQ, P", "0008AFSQ, S", "9999SQDSQ, L", "9999SQDSQ, P") '<< column headers to be copied


    Set shtSrc = Sheets("Input Sheet").Range("A:A")         '<< sheet to copy from
    Set rngDest = Sheets("Output").Range("F3") '<< starting point for pasting


    'loop over columns
    For Each hdr In arrCols


        pn = Application.Match(hdr, shtSrc.Rows(1), 0)


        If Not IsError(pn) Then
            '##Edit here##
            shtSrc.Range(shtSrc.Cells(2, pn), _
                        shtSrc.Cells(Rows.Count, pn).End(xlUp)).Copy rngDest
            '/edit
        Else
            rngDest.Value = hdr
            rngDest.Interior.Color = vbRed '<< flag missing column
        End If


        Set rngDest = rngDest.Offset(0, 1)
    Next hdr


End Sub

 

[Fluff]

No idea what you want as you haven't actually asked any questions.

But your Remove headers code can be rewritten like

Sub AArcher2()
    Dim Ary As Variant
    Dim i As Long
    
    Ary = Array("*Grade Name*", "*000*", "*999*")
    With Range("A2", Range("A" & Rows.Count).End(xlUp))
        For i = 0 To UBound(Ary)
            .Replace Ary(i), True, xlWhole, , False, , False, False
        Next i
        .SpecialCells(xlConstants, xlLogical).EntireRow.Delete
    End With
End Sub

 

[AArcher2]

No idea what you want as you haven't actually asked any questions.

But your Remove headers code can be rewritten like

Sub AArcher2()
    Dim Ary As Variant
    Dim i As Long
    
    Ary = Array("*Grade Name*", "*000*", "*999*")
    With Range("A2", Range("A" & Rows.Count).End(xlUp))
        For i = 0 To UBound(Ary)
            .Replace Ary(i), True, xlWhole, , False, , False, False
        Next i
        .SpecialCells(xlConstants, xlLogical).EntireRow.Delete
    End With
End Sub

I guess i did not express myself well. I needed help fixing the code because it wasnt removing one of the headers that meet the "*999*" criteria. I will your code and see if that works.