Keep columns , reorder them and delete the other columns

[govi]

Hi,
I have a worksheet with these about 20 columns (somtimes more an sometimes less) which have been imported in Excel.
These columns have to remain in the worksheet:

First Name

Middle Name

Last Name

Title

Company

CompanyProfile

CompanyWebsite

Email

Phone

Problem is that the order of the columns changes a lot, and the number of columns as well.
The columns mentioned above are always present when imported and I want to keep those.

What VBA do I need to keep those columns and reorder them like above and delete the other columns?

Thans for your help!
govi

 

[shrivallabha]

Here's how old fashioned VBA might look like.

Public Sub KeepSpecificColumns()
Dim arColHeadings
Dim lngHdrRow As Long: lngHdrRow = 1 '\\ Define the row number here
Dim lngLastCol As Long
'\\ Define Headings name
arColHeadings = Array("First Name", "Middle Name", "Last Name", "Title", "Company", "CompanyProfile", "CompanyWebsite", "Email", "Phone")
Application.ScreenUpdating = False
'\\ Pass 1: Check Deletion Columns
lngLastCol = Cells(lngHdrRow, Columns.Count).End(xlToLeft).Column
For i = lngLastCol To 1 Step -1
    If Not IsNumeric(Application.Match(Cells(lngHdrRow, i).Value, arColHeadings, 0)) Then
        Cells(lngHdrRow, i).EntireColumn.Delete
    End If
Next i
'\\ Pass 2: Check column position
lngLastCol = Cells(lngHdrRow, Columns.Count).End(xlToLeft).Column
For i = 1 To lngLastCol
    '\\ No need to move a column if it is already in correct place
    If Cells(lngHdrRow, i).Address <> Cells(lngHdrRow, Application.Match(Cells(lngHdrRow, i).Value, arColHeadings, 0)).Address Then
        Cells(lngHdrRow, i).EntireColumn.Cut
        Cells(lngHdrRow, Application.Match(Cells(lngHdrRow, i).Value, arColHeadings, 0)).EntireColumn.Insert Shift:=xlToRight
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Action Complete!", vbInformation
End Sub

You might be able to do this with a Power Query as well.

 

[govi]

@shrivallabha Thank you!
Works like a charm!

 

[Marc L]

Hi,​

​

I have more concise old ways - around 15 codelines, some without any loop, may be faster - but I need an attachment …​

​

 

[Marc L]

Here's how old fashioned VBA might look like.

Another old fashioned VBA from last century but working only on a smart worksheet and for good enough readers​

as it must be pasted to the worksheet module (edit v2) :​

Sub Demo1()
    V = [{"First Name","Middle Name","Last Name","Title","Company","CompanyProfile","CompanyWebsite","Email","Phone"}]
With Me.UsedRange.Columns
    If Application.Count(Application.Match(V, .Rows(1), 0)) < UBound(V) Then Beep: Exit Sub
    Application.ScreenUpdating = False
    Me.Copy
    If .Count > UBound(V) Then With .Item(UBound(V) + 1).Resize(, .Count - UBound(V)): .Clear: .ColumnWidth = Me.StandardWidth: End With
   .Cells(1).Resize(, UBound(V)) = V
    ActiveSheet.UsedRange.AdvancedFilter xlFilterCopy, , .Cells(1).Resize(, UBound(V))
End With
    ActiveSheet.Parent.Close False
    Me.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !​

​