Selecting Columns based on Value in first Row and Copy those Columns to another sheet

Question

I had a few classes of VBA over 10 years ago. Since then it changed a bit and I totally forgot how to do even the basic stuff.

I have a project at University and I would like to automate a process using VBA with Excel 2016/2017.

I get a huge Excel table from an application. From those columns I only need a couple of them based on the column name and I want to select the ones that interest me and erase the ones that don't.

I thought about a couple ways of achieving it:

1. Search all the columns with loop and copy them to a new Sheet
2. Just erase the columns that don´t interest me.

I tried different options with if and case statements but my "VBA Grammar" and knowledge are horrible. Does anyone have any tips?

Table example:

A	B	C	D	E
Customer	Product	Age	Data	Color
John	something	3	x	blue

Sheet 1

If I am only Interested in the Customer, Product and Color, how can I automate the whole process?

Thanks in advance for any tips or code snippets that could help me :)

Answer 1

Export Columns to Another Worksheet

• It will create a copy of the worksheet and delete the undesired columns.
• Adjust the values in the constants section.

Option Explicit

Sub ExportColumnsToWorksheet()
    
    ' Source
    Const sName As String = "Sheet1"
    ' Destination
    Const dName As String = "NewSheet"
    Const dColumnTitlesList As String = "Customer,Product,Color"
    
    ' Create a reference to the workbook containing this code ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Create a reference to the Source Worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Application.ScreenUpdating = False
    
    ' (Attempt to) create a reference to the Destination Worksheet ('dws').
    Dim dws As Worksheet
    On Error Resume Next
    Set dws = wb.Worksheets(dName)
    On Error GoTo 0
    If Not dws Is Nothing Then ' if it exists...
        Application.DisplayAlerts = False ' (without confirmation)
        dws.Delete ' ... delete it
        Application.DisplayAlerts = True
    End If
    
    ' Copy the worksheet as the last sheet. The copy becomes the active sheet.
    sws.Copy After:=wb.Sheets(wb.Sheets.Count)
    
    ' Create a reference to the copied worksheet i.e. the Destination Worksheet.
    Set dws = ActiveSheet
    ' Give it a name.
    dws.Name = dName
    
    ' Create a reference to the Destination Header Range
    ' (you may need a different way).
    Dim dhrg As Range: Set dhrg = dws.Range("A1").CurrentRegion.Rows(1)
    
    ' Write the column titles to the Column Titles Array ('dColumnTitles').
    Dim dColumnTitles() As String: dColumnTitles = Split(dColumnTitlesList, ",")
    
    Dim delrg As Range
    Dim dhCell As Range
    ' Loop through the cells ('dhCell') of the Destination Header Range.
    For Each dhCell In dhrg.Cells
        ' Check if the value of the current Header Cell is not found
        ' in the Column Titles Array.
        If IsError(Application.Match(CStr(dhCell.Value), dColumnTitles, 0)) Then
            ' Combine the current Header Cell into the Delete Range ('delrg').
            If delrg Is Nothing Then
                Set delrg = dhCell
            Else
                Set delrg = Union(delrg, dhCell)
            End If
        End If
    Next dhCell
    
    ' Check if no cells were combined.
    If delrg Is Nothing Then Exit Sub
    
    ' Delete the entire columns of the Delete Range.
    delrg.EntireColumn.Delete
    
    Application.ScreenUpdating = True
    
    MsgBox "The worksheet with the desired columns has been created.", _
        vbInformation, "Export Columns to Worksheet"
    
End Sub