Test for Heading, Delete Column

[Guest]

I am building a currency exchange table that consists of rates for about 50
countries. The table will be a simple matrix, with all of the countries
listed in column A, and then copied and pasted (transposed) in one row. A
simple formula in all of the intersecting cells delivers the exchange rate I
am interested in.

My problem is that I would like to delete all the columns that are not the 4
countries/currencies that will be actual destinations for my company. These 4
are:

United States, Hungary, China, Euro

Lot of info on this board about how to check for zeroes, duplicates, etc...,
but nothing I could find on deleting columns based on text headings. Probably
a small variation, but I am lost. Thanks.

 

[JE McGimpsey]

One way:

Public Sub DeleteAllBut4Columns()
Dim vKeepers As Variant
Dim rDelete As Range
Dim rCell As Range
Dim i As Long
Dim bKeep As Boolean
vKeepers = Array("United States", "Hungary", "China", "Euro")
For Each rCell In Range(Cells(1, 2), _
Cells(1, Columns.Count).End(xlToLeft))
With rCell
For i = 0 To UBound(vKeepers)
If .Value = vKeepers(i) Then
bKeep = True
Exit For
End If
Next i
If Not bKeep Then
If rDelete Is Nothing Then
Set rDelete = .Cells
Else
Set rDelete = Union(rDelete, .Cells)
End If
Else
bKeep = False
End If
End With
Next rCell
If Not rDelete Is Nothing Then rDelete.EntireColumn.Delete
End Sub

 

[JE McGimpsey]

The macro assumes that your transposed country names are in Row 1. It
checks all the cells from B1:x1, where x is the last filled column in
row 1. It checks to see if the value in each cell is one of your target
countries. If it is, the macro skips the column, otherwise it adds it to
the columns to be deleted. Finally, it deletes the non-target columns.

Where you have your selection is irrelevant, as long as the sheet is
active.

 

[JE McGimpsey]

You need to change the reference to row 9 in the next cell reference,
too:

For Each rCell In Range(Cells(9, 3), _
Cells(9, Columns.Count).End(xlToLeft))