Cleaning up My Table

AArcher2

New Member
Joined
Oct 22, 2019
Messages
3
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:

Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
33,720
Office Version
365
Platform
Windows
No idea what you want as you haven't actually asked any questions. ;)

But your Remove headers code can be rewritten like
Code:
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

New Member
Joined
Oct 22, 2019
Messages
3
No idea what you want as you haven't actually asked any questions. ;)

But your Remove headers code can be rewritten like
Code:
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.
 

Forum statistics

Threads
1,085,465
Messages
5,383,853
Members
401,858
Latest member
Nitsalet

Some videos you may like

This Week's Hot Topics

Top