Cut and insert Columns using VBA

[UseLessFuel]

Hi. I have an Excel Worksheet with 241 columns and around 46 thousand rows of numbers (no blanks anywhere). I only require 9 (nine) columns from the sheet which should be placed in Columns B to J. From recording a macro, and deleting unnecessary cursor movements, I ended up with the following code. Is there a smoother way of using VBA to carry out the same actions, or is this as efficient as can be? Thanks for your interest.

Sub OrderFromRawSD()
'
' OrderFromRawSD Macro
' From raw data (.xlsx), simply press Ctrlq to arrange the correct columns.
'
' Keyboard Shortcut: Ctrl+q
'
Columns("CQ:CQ").Select
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Columns("CL:CL").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("CM:CM").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Columns("CR:CR").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("CT:CT").Select
Selection.Cut
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Columns("CB:CB").Select
Selection.Cut
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Columns("CD:CD").Select
Selection.Cut
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Columns("M:M").Select
Selection.Cut
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Columns("W:W").Select
Selection.Cut
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Columns("K:K").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("L:BP").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
Columns("M:M").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub

 

[Rick Rothstein]

Thanks Rick. Your code works well, except for the last column (15) which is missing.
From post#5 above, Col (85) is to be placed in Col (15).

That last column was missing because I forgot to include a +1 in one of the code lines (shown in red below) to account for the fact that the Arr array starts indexing at 0, not 1 (nothing else needed to be changed). I also simplified the last line of code a little bit. Here is the revised, working code...

[table="width: 500"]
[tr]
	[td]Sub CopyColumns2()
  Dim LastRow As Long, Arr As Variant, Wbk As Workbook, Ws As Worksheet
  Arr = Array(1, 95, 89, 90, 96, 98, 16384, 75, 77, 6, 16, 16384, 83, 84, 85)
  With ActiveSheet
    LastRow = .Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
    Set Wbk = Workbooks.Add
    Set Ws = Wbk.Sheets(1)
    Ws.Range("A1").Resize(LastRow, UBound(Arr) [B][COLOR="#FF0000"]+ 1[/COLOR][/B]) = Application.Index(.Cells, Evaluate("ROW(1:" & LastRow & ")"), Arr)
  End With
  Ws.Range("G2:G" & LastRow).Formula = "=E2-F2"
End Sub[/td]
[/tr]
[/table]

 

[UseLessFuel]

Thanks Rick - it works perfectly now, and appears to be slightly quicker (near instant) than Fluff's code, though I'm happy to get either! Many thanks to you all.

 

[Fluff]

Glad we could help & thanks for the feedback