Macro to copy two sheets and delete columns based on headers

[thelad]

Hi,

The following macro is working for me. I'm just wondering would anyone write this differently?

Currently it uses 5 for loops to search the copied sheet for 5 different headers that will be on the sheet multiple times and deletes allcolumns thatcontain these headers.

Its working but just seeing if anyone has a better way or to make faster:

Your help is appreciated:

Sub CommandButton1_Click()
Dim OutlookApp As Object
Dim MItem As Object
Dim Wb As Workbook
Dim NewWb As Workbook
Dim lastCol As Long
Dim delCol As Long

Application.ScreenUpdating = False

'Create Excel sheet link
Set Wb = ActiveWorkbook

Sheets(Array(Sheet2.Name, Sheet3.Name)).Copy
Set NewWb = ActiveWorkbook

astCol = Cells(1, Columns.Count).End(xlToLeft).Column
For delCol = lastCol To 1 Step -1
If Cells(1, delCol) = "ID Number" Then _
Cells(1, delCol).EntireColumn.Delete
Next

lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For delCol = lastCol To 1 Step -1
If Cells(1, delCol) = "Par" Then _
Cells(1, delCol).EntireColumn.Delete
Next

lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For delCol = lastCol To 1 Step -1
If Cells(1, delCol) = "Transaction Code" Then _
Cells(1, delCol).EntireColumn.Delete
Next

lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For delCol = lastCol To 1 Step -1
If Cells(1, delCol) = "Identifier" Then _
Cells(1, delCol).EntireColumn.Delete
Next

lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For delCol = lastCol To 1 Step -1
If Cells(1, delCol) = "Date" Then _
Cells(1, delCol).EntireColumn.Delete
Next

Application.ScreenUpdating = True


End Sub

 

[Nalani]

See if you can implement this bit of code for your 5 loops:

Sub test()
    Dim lastCol As Long
    Dim delCol As Long
    Dim myCols
 
    myCols = Array("ID Number", "Par", "Identifier", "Date")
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
 
    For i = 0 To UBound(myCols)
        For delCol = lastCol To 1 Step -1
            If Cells(1, delCol) = myCols(i) Then
                Cells(1, delCol).EntireColumn.Delete
            End If
       Next
    Next i
End Sub

Fill in you Array as required. I just put a few in for testing.

 

[thelad]

Hi,

Thanks I tried it and worked perfectly as before. Thank you again. I am working on something further on this macro but having a problem. If I post it could you have a look if you get a chance please?

I'm going to give it another day and see if can figure it out but if can't be grateful if you could have a look.