VBA to find and delete columns.

Hi,
I have sheet "Working". In this I have a column with Heading New Sheet1, New Sheet2, New Sheet3, New Sheet4, New Sheet5 and New Sheet6.

I need a macro to find above Heading New Sheet1, New Sheet2, New Sheet3, New Sheet4, New Sheet5 and New Sheet6 in Row number 1 and if it exist then delete those columns.

And find last filled column in the same sheet and add new 6 columns with same heading New Sheet1, New Sheet2, New Sheet3, New Sheet4, New Sheet5 and New Sheet6

The Column heading format should be in Red font.bold and backgroung yellow colour

Somehow.... But not exactly.

Because these columns may anywhere in the the sheet, Between any columns or first last or in a MID. Also wanted clear contents in existing columns. Hence Wanted to find and delete these columns and insert new columns (one after one) after a last column,

Try this:

Sub b1292485b()

Dim x As Long
Dim z, fm

Application.ScreenUpdating = False
x = Cells(1, Columns.count).End(xlToLeft).Column

For Each z In Array("New Sheet1", "New Sheet2", "New Sheet3", "New Sheet4", "New Sheet5", "New Sheet6")
    fm = Application.Match(z, Range("A1").Resize(, x), 0)
    
    If IsNumeric(fm) Then
        Columns(fm).Delete xlToLeft
            With Cells(1, x)
                .Value = z
                .Font.Color = vbRed
                .Font.Bold = True
                .Interior.Color = vbYellow
            End With
    End If

Next

Application.ScreenUpdating = True
End Sub

hi,
Please check the attachment the code is not running

Does this macro do what you want...

Sub DeleteNewSheetColumns()
  With Range("B1", Cells(1, Columns.Count).End(xlToLeft))
    .Value = Evaluate(Replace("IF((LEFT(@,9)=""New Sheet"")*(ISNUMBER(FIND(RIGHT(@),""123456""))),""#N/A"",@)", "@", .Address))
    On Error Resume Next
    .SpecialCells(xlConstants, xlErrors).EntireColumn.Delete
    On Error GoTo 0
  End With
  With Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 6)
    .Value = Array("New Sheet1", "New Sheet2", "New Sheet3", "New Sheet4", "New Sheet5", "New Sheet6")
    .Interior.Color = vbYellow
    .Font.Bold = True
    .Font.Color = vbRed
  End With
End Sub

Hi, I have given Column Heading Starting with "New Sheet" just for an example.

Actuall I have 10 columns with below headings. And more can be added / deleted in future. Can you provide your accordingly.


No_Annualised_Claims
No_Annualised_Claims_With_IBNR
Annualised_Claim_Amount
Annualised_Claim_Amount_With_IBNR
Age_Band_1
Age_Band_2
Age_Band_3
Age_Band_4
Age_Band_5
Amount_Band

Originally Posted by saravanan1981

No_Annualised_Claims
No_Annualised_Claims_With_IBNR
Annualised_Claim_Amount
Annualised_Claim_Amount_With_IBNR
Age_Band_1
Age_Band_2
Age_Band_3
Age_Band_4
Age_Band_5
Amount_Band

Question... are the above headers the only headers that have red bold font in a yellow filled cell? If so, here is another macro that you can consider...

Sub DeleteHeadersWithYellowFillAndRedBoldFont()
  With Application.FindFormat
    .Clear
    .Interior.Color = vbYellow
    .Font.Bold = True
    .Font.Color = vbRed
    Rows(1).Replace "", "#N/A", , , , , True, False
    .Clear
  End With
  On Error Resume Next
  Rows(1).SpecialCells(xlConstants, xlErrors).EntireColumn.Delete
  With Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 10)
    .Value = Array("No_Annualised_Claims", "No_Annualised_Claims_With_IBNR", "Annualised_Claim_Amount", "Annualised_Claim_Amount_With_IBNR", "Age_Band_1", "Age_Band_2", "Age_Band_3", "Age_Band_4", "Age_Band_5", "Amount_Band")
    .Interior.Color = vbYellow
    .Font.Color = vbRed
    .Font.Bold = True
    .EntireColumn.AutoFit
  End With
End Sub

Note: If those headers are the only header with yellow fill, then you can remove the two lines of code I highlighted in red above.

Sub test()
    Dim myList, e
    myList = Array("New Sheet1", "New Sheet2", "New Sheet3", "New Sheet4", "New Sheet5", "New Sheet6")
    On Error Resume Next
    For Each e In myList
        Rows(1).Find(e, , , 1).EntireColumn.Delete
    Next
    On Error GoTo 0
    With Cells(1).CurrentRegion
        With .Columns(.Columns.Count + 1).Cells(1).Resize(, UBound(myList) + 1)
            .Value = myList
            .Font.Color = vbRed: .Font.Bold = True
            .Interior.Color = vbYellow
        End With
    End With
End Sub

Dear Jindon,
I tried it on sample file. It is not deleting all existing column with same heading.
at final result only 10 columns to be there after running the code. that too it start from the last column

Add/remove the item in myList.

Sub test()
    Dim myList, e, r As Range
    myList = Array("No_Annualised_Claims", "No_Annualised_Claims_With_IBNR", _
            "Annualised_Claim_Amount", "Annualised_Claim_Amount_With_IBNR", _
            "Age_Band_1", "Age_Band_2", "Age_Band_3", "Age_Band_4", "Age_Band_5", _
            "Amount_Band")
    For Each e In myList
        Set r = Rows(1).Find(e, , , 1)
        If Not r Is Nothing Then
            Do
                r.EntireColumn.Delete
                Set r = Rows(1).Find(e, , , 1)
            Loop Until r Is Nothing
        End If
    Next
    With Cells(1).CurrentRegion
        With .Columns(.Columns.Count + 1).Cells(1).Resize(, UBound(myList) + 1)
            .Value = myList
            .Font.Color = vbRed: .Font.Bold = True
            .Interior.Color = vbYellow
        End With
    End With
End Sub

thats perfect