Move Columns Which Meet Criteria with a VBA Array

In Excel VBA you can move certain columns of your choice with the help of VBA. This article shows you how to exclude columns. Moving data in Excel is not always as straight forward as moving the Current Region or a fixed range. Quite often you may only wish to take a smaller dataset to a summary sheet. Often this dataset will not be sequential and this is where things get a little more complicated. When you know where the data is in the file you can assign the column numbers to an Array. This allows you to iterate through each column and move the data, Column by Column. You can do this with the following method;


Option Explicit

Sub MoveCol1() 'Excel VBA to move Columns based on criteria
Dim ar As Variant
Dim i As Integer

'Set the Array Values to the Columns Numbers you are copying
ar=Array(1, 5, 7, 9, 11)


For i=0 To UBound(ar) 'Loop through the Array
Columns(ar(i)).Copy Sheet2.Cells(1, i + 1) 'Add 1 at end as array starts at 0
Next i
End Sub

Find Column Text and Copy the Column

This process is a little more complex when you do not know where in the file the headers will be. If I use the find method I can trap the location of the column and then move the data based on the Columns position in the sheet. Here is an example;



Option Explicit

Sub MoveCol2() 'Excel VBA to move Columns based on criteria
Dim ar As Variant
Dim i As Integer
Dim j As Long

'Set the Array Values
ar=Array("Sales", "Dept 1", "Dept 8", "Dept 9")

For i=0 To UBound(ar) 'Loop through the Array
j=[A1:AW1].Find(ar(i)).Column
Columns(j).Copy Sheet2.Cells(1, i + 1) 'Add 1 at end as array starts at 0
Next i
End Sub

Perform No Action Unless Found

The above procedures have made the assumption a find will be made. The following will deal with a situation where the data you are searching for is not found. It will only execute the copy of data if the header text is found.



Option Explicit

Sub cols() 'Excel VBA to trap an error if not found.
Dim i As Integer
Dim ar As Variant
Dim sh As Worksheet
Dim lr As Long
Dim rng As Range

Set sh=Sheet1
ar=sh.Range("A1", sh.Range("IV1").End(xlToLeft))
lr=sh.Range("A" & Rows.Count).End(xlUp).Row

For i=1 To sh.Range("IV1").End(xlToLeft).Column
Set rng=Sheet2.Rows("1:1").Find(ar(1, i), LookAt:=xlWhole)
If Not rng Is Nothing Then 'found
sh.Range(sh.Cells(1, i), sh.Cells(lr, i)).Copy rng
End If
Next i
End Sub


This is a safer way to run the procedure as a run time error will be avoided.

Capturing Columns Location and Copying Once Only

You can improve on the above with a bit of forethought. The ideal situation would be to trap the location of each of the Columns. I want to shift and move all the data at once in a batch process of sorts. When looking up larger lists of data this process can be a lot more efficient as the Copy and Paste happens once at the end. If, for example, I had 20 items with the original method I would need 20 actions to shift the data. With the following procedure there is only one action required.



Option Explicit

Sub MoveCols3() 'Excel VBA to move Columns based on criteria
Dim r As Range
Dim ar As Variant
Dim i As Integer
Dim fn As Range
Dim str As String

'Set the Array Values
ar=Array("Sales", "Dept 1", "Dept 8", "Dept 9")
For i=0 To UBound(ar) 'Loop through the Array
Set fn=[A1:AW1].Find(ar(i), LookAt:=xlWhole)
str=str & fn.Address & ","
Next i 'Take the trailing comma from the string
str=Left(str, Len(str) - 1)
Set r=Range(str).EntireColumn
r.Copy Sheet2.[a1] 'Copy and Paste to new sheet in cell A1.
End Sub


The above method is far superior to the prior methods as more efficient. The trick to it is creating a string of values from the address where the cell is found. So fn (the variable) is Assigned to a range, it starts the Search for the word Sales in the Header Row, row 1. When the item is found the variable fn has a Cell location. Once all of these cell locations are trapped at the end they are copied. It is the fact that the data is copied once which makes this final method the most efficient choice.