How to reword this code?

[Desu Nota from Columbus]

I have the following code that reorders my columns. It uses a ton of .select (which isn't advantageous) and I wondered if there is a direct way to say the following:

Columns("D:D").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("R:R").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("G:G").Select
    Selection.Cut
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    Columns("L:L").Select
    Selection.Cut
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight
    Columns("M:M").Select
    Selection.Cut
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    Columns("O:O").Select
    Selection.Cut
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Cut
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    Columns("L:L").Select
    Selection.Cut
    Columns("K:K").Select
    Selection.Insert Shift:=xlToRight
    Columns("N:N").Select
    Selection.Cut
    Columns("M:M").Select
    Selection.Insert Shift:=xlToRight
    Columns("R:R").Select
    Selection.Cut
    Columns("K:K").Select
    Selection.Insert Shift:=xlToRight
    Columns("R:R").Select
    Selection.Cut
    Columns("L:L").Select
    Selection.Insert Shift:=xlToRight
    Columns("R:R").Select
    Selection.Cut
    Columns("Q:Q").Select
    Selection.Insert Shift:=xlToRight
    Columns("T:T").Select
    Selection.Cut
    Columns("Q:Q").Select
    Selection.Insert Shift:=xlToRight
    Range("S:U").Delete
    Range("A1").Select

 

[rs2k]

I just tried this and it seems to work, I used any columns for the test, so you will have to amend to suit your range, but the sturucture seems to be there;

Sub test()
Columns("C").Cut
Columns("B").Insert Shift:=xlToRight
Columns("H").Cut
Columns("D").Insert Shift:=xlToRight
Columns("F").Cut
Columns("G").Insert Shift:=xlToRight
Columns("C").Cut
Columns("A").Insert Shift:=xlToRight
Columns("O").Cut
Columns("N").Insert Shift:=xlToRight
End Sub

HTH
Colin

 

[Desu Nota from Columbus]

I just tried this and it seems to work, I used any columns for the test, so you will have to amend to suit your range, but the sturucture seems to be there;

Sub test()
Columns("C").Cut
Columns("B").Insert Shift:=xlToRight
Columns("H").Cut
Columns("D").Insert Shift:=xlToRight
Columns("F").Cut
Columns("G").Insert Shift:=xlToRight
Columns("C").Cut
Columns("A").Insert Shift:=xlToRight
Columns("O").Cut
Columns("N").Insert Shift:=xlToRight
End Sub

HTH
Colin

For some reason I expected the method to be complex--using either an array or index.

Simpler is better though!

I will tailor this to fit my needs. Thank you.

 

[rs2k]

There are probably better ways to do it, but I couldn't see a pattern in the columns you were cutting and the columns you were moving, it seems that they are specific to the way your data is laid out as opposed to a repeating structure... does that make sense???

Colin

 

[p45cal]

I tried rs2k's solution but it didn't come ouit in the same order as yours did.
The following is what I did before realising you already had an answer:

Sub blah()
Columns("R:R").Cut: Columns("B:B").Insert
Columns("E:G").Cut: Columns("C:E").Insert
Columns("L:M").Cut: Columns("G:G").Insert
Columns("o:o").Cut: Columns("i:i").Insert
Columns("R:R").Cut: Columns("k:k").Insert
Columns("R:R").Cut: Columns("l:l").Insert
Columns("n:n").Cut: Columns("m:m").Insert
Columns("p:p").Cut: Columns("o:o").Insert
Columns("t:t").Cut: Columns("q:q").Insert
Columns("s:s").Cut: Columns("r:r").Insert
Range("S:U").Delete
Range("A1").Select
End Sub

 

[Desu Nota from Columbus]

rs2k's answer was to show me the syntax for restructuring columns without using the recorded macro's method of select, move selection.

You were correct in assuming that there was no pattern to the column reorder--the columns are returned from a database in alphabetical order and then I reorder them to put important columns adjacent to one another.

 

[rs2k]

See if this is any better. I stumbled across a post from Jon Von Der Heyden and added a bit of code to create a new sheet and add the column headings in the order you want them, then run Jon's code to copy the data across;

Sub test2()
'Rearrange columns into workable order
Application.ScreenUpdating = False 'Stops screen from flickering and processes macro faster

'Create new sheet and rename
Sheets.Add.Name = "Report"
'create headings in the order you want them, CHECK SPELLINGS!
Range("A1").Value = "Heading 1"
Range("B1").Value = "Heading 18"
Range("C1").Value = "Heading 4"
Range("D1").Value = "Heading 5"
Range("E1").Value = "Heading 6"
Range("F1").Value = "Heading 2"
Range("G1").Value = "Heading 11"
Range("H1").Value = "Heading 12"
Range("I1").Value = "Heading 14"
Range("J1").Value = "Heading 3"
Range("K1").Value = "Heading 17"
Range("L1").Value = "Heading 16"
Range("M1").Value = "Heading 8"
Range("N1").Value = "Heading 7"
Range("O1").Value = "Heading 10"
Range("P1").Value = "Heading 9"
Range("Q1").Value = "Heading 13"
Range("R1").Value = "Heading 15"

Dim rCell As Range

For Each rCell In Sheets("Report").Rows(1).SpecialCells(xlCellTypeConstants) 'Assumes headers are inputted in row 1 in Report.  Loops through headers in Report.
    On Error Resume Next 'If no match is found move to next iteration
    With Sheets("Sheet1")
        .Columns(Application.Match(rCell, .Rows(1), 0)).Copy rCell 'Copy column that matching Report header and paste into Report.  Assumes column headers in Master are in row 1.
    End With
Next rCell

End Sub

HTH
Colin

 

[Desu Nota from Columbus]

Thanks for going the extra mile!