Can anyone optimise this VBA code (moving columns to another sheet)

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
785
Office Version
  1. 365
Platform
  1. Windows
Hi,
i have the following code which works fine (recorded macro) but it takes nearly 20 seconds to complete. Any tips to speed this up?

Code:
Sub Macro3()Sheets("fg").Select
Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("A:A,K:K").AutoFilter Field:=15, Criteria1:="TypeA"
    ActiveSheet.Range("A:A,K:K").AutoFilter Field:=1, Criteria1:="=MSR", _
        Operator:=xlOr, Criteria2:="=MRQP"
    Range("A:A,Z:Z").Select
    Selection.Copy
    Sheets("Sheet3").Select
     Range("A1").Select
    ActiveSheet.Paste
    Sheets("fg").Select
    Range("B:B,O:O").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet3").Select
    Range("C1").Select
    ActiveSheet.Paste
    Sheets("fg").Select
    Range("C:C,P:P").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet3").Select
    Range("E1").Select
    ActiveSheet.Paste
    Sheets("fg").Select
    Range("L:L,X:X").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet3").Select
    Range("G1").Select
    ActiveSheet.Paste
    Sheets("fg").Select
    Range("AA:AA,AG:AG").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet3").Select
    Range("I1").Select
    ActiveSheet.Paste
    Sheets("fg").Select
    Range("AC:AC,AH:AH").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet3").Select
    Range("K1").Select
    ActiveSheet.Paste
    Range("A1:L1").Select
    Selection.Font.Bold = True
 Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("F:F").EntireColumn.AutoFit
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").EntireColumn.AutoFit
    Columns("J:J").EntireColumn.AutoFit
    Columns("K:K").EntireColumn.AutoFit
    Columns("L:L").EntireColumn.AutoFit
    Columns("I:J").Select
    Selection.Cut
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    Sheets("fg").Select
    ActiveSheet.ShowAllData
    Selection.AutoFilter
End Sub

What its needed to do:

Filters Field 15 (Column O)
Filters Field 1 (Column A)

Copys the filtered columns to sheet 3 in this order:
A,Z,B,AA,AG,O,C,P,L,X,AC,AH

Autofit Column widths in Sheet 3

Thanks in advance
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
i got this code which copies the colums faster thanks to Peter_SSs from this post: http://www.mrexcel.com/forum/excel-...le-columns-one-sheet-another.html#post1382155

Code:
Sub SortSM()
Dim wsCore As Worksheet
Dim wsData As Worksheet

Set wsCore = Sheets("Sheet1")
Set wsData = Sheets("Sheet3")
Application.ScreenUpdating = False

With wsCore
.Columns("A").Copy Destination:=wsData.Columns("A")
.Columns("Z").Copy Destination:=wsData.Columns("B")
.Columns("B").Copy Destination:=wsData.Columns("C")
.Columns("AA").Copy Destination:=wsData.Columns("D")
.Columns("AG").Copy Destination:=wsData.Columns("E")
.Columns("O").Copy Destination:=wsData.Columns("F")
.Columns("C").Copy Destination:=wsData.Columns("G")
.Columns("P").Copy Destination:=wsData.Columns("H")
.Columns("L").Copy Destination:=wsData.Columns("I")
.Columns("X").Copy Destination:=wsData.Columns("J")
.Columns("AC").Copy Destination:=wsData.Columns("K")
.Columns("AH").Copy Destination:=wsData.Columns("L")
End With

Application.ScreenUpdating = True
Set wsCore = Nothing
Set wsData = Nothing
End Sub

though im having trouble filtering data before copying, then renaming the column headers and making bold / auto width columns

i tried this to autofilter but it just errors
Code:
.Columns("O").AutoFilter Field:=15, Criteria1:=TypeA
 
Upvote 0
Hi,

Does this get you any closer to your requirements...

Code:
Sub test()


    Dim Cols
    Dim i As Long, lRow As Long
    Dim coluRng As Range
    
    Application.ScreenUpdating = False
    Set coluRng = Columns("A:AZ").Cells
    lRow = coluRng(Cells.Find(What:="*", SearchOrder:=xlRows, _
        SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
        Cells.Find(What:="*", SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column).Row
    Sheets("fg").Range("A1:AZ" & lRow).AutoFilter
    ActiveSheet.Range("A1:AZ" & lRow).AutoFilter Field:=15, Criteria1:="TypeA"
    ActiveSheet.Range("A1:AZ" & lRow).AutoFilter Field:=1, Criteria1:="=MSR", _
        Operator:=xlOr, Criteria2:="=MRQP"
    Cols = Array("a", "z", "b", "aa", "ag", "o", "c", "p", "l", "x", "ac", "ah")
    For i = LBound(Cols) To UBound(Cols)
        Range(Cols(i) & 1, Cols(i) & lRow).Copy Worksheets("Sheet3").Cells(1, i + 1)
    Next
    Worksheets("Sheet3").Columns.AutoFit
    Sheets("fg").Select
    ActiveSheet.ShowAllData
    Selection.AutoFilter
    Application.ScreenUpdating = True


End Sub

I hope this helps.

igold
 
Upvote 0
Hi,

Does this get you any closer to your requirements...

Code:
Sub test()


    Dim Cols
    Dim i As Long, lRow As Long
    Dim coluRng As Range
    
    Application.ScreenUpdating = False
    Set coluRng = Columns("A:AZ").Cells
    lRow = coluRng(Cells.Find(What:="*", SearchOrder:=xlRows, _
        SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
        Cells.Find(What:="*", SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column).Row
    Sheets("fg").Range("A1:AZ" & lRow).AutoFilter
    ActiveSheet.Range("A1:AZ" & lRow).AutoFilter Field:=15, Criteria1:="TypeA"
    ActiveSheet.Range("A1:AZ" & lRow).AutoFilter Field:=1, Criteria1:="=MSR", _
        Operator:=xlOr, Criteria2:="=MRQP"
    Cols = Array("a", "z", "b", "aa", "ag", "o", "c", "p", "l", "x", "ac", "ah")
    For i = LBound(Cols) To UBound(Cols)
        Range(Cols(i) & 1, Cols(i) & lRow).Copy Worksheets("Sheet3").Cells(1, i + 1)
    Next
    Worksheets("Sheet3").Columns.AutoFit
    Sheets("fg").Select
    ActiveSheet.ShowAllData
    Selection.AutoFilter
    Application.ScreenUpdating = True


End Sub

I hope this helps.

igold

this is perfect, thankyou
pretty much instant now :)
 
Upvote 0
posting this in here rather than create a new thread, i have this code

Code:
Range("D2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[10]="""","""",TEXT(RC[10],""00\:00\:00"")+0)"
    Selection.AutoFill Destination:=Range("D2:D500"), Type:=xlFillDefault

which puts a formula in D2 and drags the formula down to D500
but i dont always need all those rows, is there a better way to do this

with the formula going 500 cells down, when printing there is lots of blank pages

if this makes sense
 
Last edited:
Upvote 0
^ found solution to the above

this is it if anyone needs, works fine

Code:
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown

Range(A1) is to the left of the column you want to populate
 
Upvote 0
What determines how many rows you want to go down. Is it the last row of data in a certain column?
 
Upvote 0
What determines how many rows you want to go down. Is it the last row of data in a certain column?

yes
the above code works just as i need but not sure if theres a better way

i have anything between 50 and 1000 rows depending on circumstances so i only need the formula to populate rows with data
 
Upvote 0
Ideally, you do not want to select anything. You do not have to select a cell to perform an action on it. Selecting cells slows your code down drastically.

I was trying to come up with a code that did not select any cells but to get the AutoFill to work I had to use select once. Is it better than what you posted, I don't know, but it does minimize the number of times you actually select a cell. That was one of your problems in your Post #1. Count how many times you selected a cell or range to act upon it.

That being said this what I came up with. Perhaps one of the more knowledgeable forum members will post a more efficient code...

Code:
Sub test2()
Dim lrow As Long
lrow = Range("A1").End(xlDown).Row
Range("A1").Offset(0, 1).Select
Selection.AutoFill Range(Selection, Selection.Offset(lrow - 1))
End Sub

igold
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,237
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top