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

J

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
759
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

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
J

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
759
Office Version
  1. 365
Platform
  1. Windows
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
igold

igold

Well-known Member
Joined
Jul 8, 2014
Messages
3,263
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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
J

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
759
Office Version
  1. 365
Platform
  1. Windows
igold said:
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
Click to expand...

this is perfect, thankyou
pretty much instant now :)
 
Upvote 0
igold

igold

Well-known Member
Joined
Jul 8, 2014
Messages
3,263
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Great, glad I could help. Thanks for the feedback.

igold
 
Upvote 0
J

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
759
Office Version
  1. 365
Platform
  1. Windows
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
J

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
759
Office Version
  1. 365
Platform
  1. Windows
^ 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
igold

igold

Well-known Member
Joined
Jul 8, 2014
Messages
3,263
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
What determines how many rows you want to go down. Is it the last row of data in a certain column?
 
Upvote 0
J

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
759
Office Version
  1. 365
Platform
  1. Windows
igold said:
What determines how many rows you want to go down. Is it the last row of data in a certain column?
Click to expand...

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
igold

igold

Well-known Member
Joined
Jul 8, 2014
Messages
3,263
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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
You must log in or register to reply here.

Similar threads

cmschmitz24
  • Question
Need Excel VBA to move multiple rows into 1 row
Replies
0
Views
104
cmschmitz24
cmschmitz24
N
  • Question
Changing recorded macro when trying to format a sheet - Need dynamic selection of cells
Replies
2
Views
120
nidhinair22
N
J
  • Question
Importing a Module
Replies
1
Views
79
jorgan202
J
S
  • Question
Can I combine these small macros into one big macro?
Replies
4
Views
143
johnnyL
J
J
  • Question
Repaired Part: /xl/worksheet/sheet31.xml-Part
Replies
1
Views
142
RoryA
RoryA

Forum statistics

Threads
1,191,174
Messages
5,985,107
Members
439,940
Latest member
Kyrad42

Share this page

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
Top