Multi-stage Macro help - inserting column, searching and moving multiple values, deleting

[phpolicylady]

I'm having trouble with a macro that I'm trying to build to do many steps.

Our financial system exports budget data in terribly unhelpful excel files (thus necessitating the continued use of the pdf reports within the program). However, I have been asked to create a budget planning tool that will work from these poorly delineated excel exports.

Data exports look like: UglyExport.xlsx
(actual data has been altered for security reasons)

My macro thus far:

Option Explicit
Sub Delete_Based_on_Page()
' This macro will delete an entire row based on the presence of a
'predefined word or set of words.  If that word or set of words is
'found in a cell, in a specified column, the entire row will be deleted
Dim x As Long
Dim Z As Long
Dim lastrow As Long
Dim FoundRowToDelete As Boolean
Dim OriginalCalculationMode As Long
Dim RowsToDelete As Range
Dim SearchItems() As Variant
Dim DataStartRow As Long
Dim SearchColumn As String
Dim SheetName As String
' Choose the row you want the search and delete to start on
' Choose the column to search and delete to use for deletion
' Choose the sheet in the workbook you want this macro to be run on
DataStartRow = 4
SearchColumn = "A"
SheetName = "Sheet1"
' Enter the terms you want to be used for criteria for deletion
' All terms entered below are CASE SENSITIVE and need to be
'seperated by a comma
SearchItems = Array("Page", "Services", "Supplies", "Capital", "Costs", "TOTAL", "Salaries")
On Error GoTo Whoops
OriginalCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With Worksheets(SheetName)
lastrow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row
For x = lastrow To DataStartRow Step -1
FoundRowToDelete = False
For Z = 0 To UBound(SearchItems)
If InStr(.Cells(x, SearchColumn).Value, SearchItems(Z)) Then
FoundRowToDelete = True
Exit For
End If
Next
If FoundRowToDelete Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Cells(x, SearchColumn)
Else
Set RowsToDelete = Union(RowsToDelete, .Cells(x, SearchColumn))
End If
If RowsToDelete.Areas.Count > 100 Then
RowsToDelete.EntireRow.Delete
Set RowsToDelete = Nothing
End If
End If
Next
End With
If Not RowsToDelete Is Nothing Then
RowsToDelete.EntireRow.Delete
End If
Whoops:
Application.Calculation = OriginalCalculationMode
Application.ScreenUpdating = True
 
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Dim rngFound As Range
    Dim strSearch As Variant
    strSearch = Array("11", "12", "13", "21", "31", "32", "33", "34", "35", "36", "41", "51", "52", "53", "61", "81")
    Set rngFound = Cells.Find(What:=strSearch, After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    rngFound.Cut Destination:=rngFound.Offset(1, -1)
    Set rngFound = Nothing
    

End Sub

So far I have found various posts that have gotten me to where I am now. I have copied code from several places, hacked it until I made it do what I wanted, and now I'm stuck.

Goals for the macro:

1. Delete rows with subtotals (those with words like Salaries and TOTAL) to leave only data per line item
2. Insert a column
3. Find and move specific strings (11, 12, 13, etc) back one column and down one row
4. Copy the found string (11, 12, 13, etc) down to the next empty row
5. delete the empty rows
6. format the data as a table

So far - I can get the first two objectives to work perfectly as I want them.

I can get part of the third objective to work, but not all. I need it to search for each instance of the selected strings, but it only finds the first instance of 11 and then stops.

specific code for that part:

    Dim rngFound As Range
    Dim strSearch As Variant
    strSearch = Array("11", "12", "13", "21", "31", "32", "33", "34", "35", "36", "41", "51", "52", "53", "61", "81")
    Set rngFound = Cells.Find(What:=strSearch, After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    rngFound.Cut Destination:=rngFound.Offset(1, -1)
    Set rngFound = Nothing

Since I copied all of this from other places, I don't really know what I'm doing here, so I don't know how to fix it.

I'm fairly certain I can create the other parts of the macro by myself, but this part is causing me troubles I can't seem to fix.

Any and all help is greatly appreciated!!!

[mrice]

Try this

Sub Test()
Dim N As Long
For N = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
    If (Len(Cells(N, 1)) <> 4 And Len(Cells(N, 1)) <> 2) Or IsNumeric(Cells(N, 1)) = False Then
        Rows(N).Delete
    End If
Next N
Columns(1).Insert
For N = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
    If Len(Cells(N, 2)) = 2 Then
        Cells(N + 1, 1) = Cells(N, 2)
        Cells(N, 2) = ""
    End If
Next N

For N = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
    If Cells(N, 2) <> "" And Cells(N, 1) = "" Then
        Cells(N, 1) = Cells(N, 1).End(xlUp)
    End If
Next N

For N = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
    If Cells(N, 1) = "" Then
        Rows(N).Delete
    End If
Next N
End Sub

[phpolicylady]

Thanks!

Question - do I replace a particular portion of my previous code with that which you provided?

subquestion - is it going to be a problem that the numbers are stored as text? I notice that you have IsNumeric in there, so I'm not sure.

[mrice]

It is designed to be a complete replacement.

The formatting of the numbers should not matter - the isnumeric function looks to see if the characters can be interpreted as a number.

The code was tested on your sample data set.

[phpolicylady]

It works beautifully!!!!

Thanks so much!!!!