Tidying/Amending code

P

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,227
Office Version
  1. 2010
Platform
  1. Windows
Hi just wondering is there any way of tidying up the code below as it is repeated quite a lot just wondering if there was a easier/better way in putting it all together. hope you can help.

Code: 
Private Sub CommandButton3_Click()
With Sheets("Sheet1")
        .Columns("C:C").Sort Key1:=.Range("C:C"), Order1:=xlDescending, Header:=xlYes
End With
 
 
  Set copySheet = Worksheets("Sheet1")
  Set pasteSheet = Worksheets("New")
  
    With copySheet
    .Range(.Cells(2, "C"), .Cells(.Cells(Rows.Count, "C").End(xlUp).Row, "C")).Copy
  End With
  
  pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     Range("B2", Range("B2").End(xlDown)).NumberFormat = "0"
  
           With copySheet
   .Range(.Cells(2, "F"), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, "F")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 33).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     
          With copySheet
   .Range(.Cells(2, "F"), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, "F")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 34).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
  
  With copySheet
   .Range(.Cells(2, "L"), .Cells(.Cells(Rows.Count, "L").End(xlUp).Row, "L")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     
       With copySheet
   .Range(.Cells(2, "M"), .Cells(.Cells(Rows.Count, "M").End(xlUp).Row, "M")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 19).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     
               With copySheet
   .Range(.Cells(2, "Q"), .Cells(.Cells(Rows.Count, "Q").End(xlUp).Row, "Q")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 17).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     
    Application.ScreenUpdating = False
    With Range("Q2", Range("Q" & Rows.Count).End(xlUp))
        .EntireColumn.Insert
        .NumberFormat = "@"
        With .Offset(, -1)
            .FormulaR1C1 = "=Text(RC[1],""dd/mm/YYYY"")"
            .Offset(, 1).Value = .Value
            .EntireColumn.Delete
        End With
    End With
    Application.ScreenUpdating = True
    lr = Sheets("New").Cells(Rows.Count, "B").End(xlUp).Row
    Sheets("New").Range("A3:A" & lr) = Sheets("New").Range("A2")

End Sub
 
Sort by date Sort by votes
So you just want it to paste in row 2 in the columns indicated by your code in post 1?
 
Upvote 0

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Hi yes please. Did I get it right in what I did. Thanks for your help




Patriot2879 said:
Hi just wondering is there any way of tidying up the code below as it is repeated quite a lot just wondering if there was a easier/better way in putting it all together. hope you can help.

Code: 
Private Sub CommandButton3_Click()
With Sheets("Sheet1")
        .Columns("C:C").Sort Key1:=.Range("C:C"), Order1:=xlDescending, Header:=xlYes
End With
 
 
  Set copySheet = Worksheets("Sheet1")
  Set pasteSheet = Worksheets("New")
  
    With copySheet
    .Range(.Cells(2, "C"), .Cells(.Cells(Rows.Count, "C").End(xlUp).Row, "C")).Copy
  End With
  
  pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     Range("B2", Range("B2").End(xlDown)).NumberFormat = "0"
  
           With copySheet
   .Range(.Cells(2, "F"), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, "F")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 33).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     
          With copySheet
   .Range(.Cells(2, "F"), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, "F")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 34).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
  
  With copySheet
   .Range(.Cells(2, "L"), .Cells(.Cells(Rows.Count, "L").End(xlUp).Row, "L")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     
       With copySheet
   .Range(.Cells(2, "M"), .Cells(.Cells(Rows.Count, "M").End(xlUp).Row, "M")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 19).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     
               With copySheet
   .Range(.Cells(2, "Q"), .Cells(.Cells(Rows.Count, "Q").End(xlUp).Row, "Q")).Copy
    End With
     pasteSheet.Cells(Rows.Count, 17).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
     
    Application.ScreenUpdating = False
    With Range("Q2", Range("Q" & Rows.Count).End(xlUp))
        .EntireColumn.Insert
        .NumberFormat = "@"
        With .Offset(, -1)
            .FormulaR1C1 = "=Text(RC[1],""dd/mm/YYYY"")"
            .Offset(, 1).Value = .Value
            .EntireColumn.Delete
        End With
    End With
    Application.ScreenUpdating = True
    lr = Sheets("New").Cells(Rows.Count, "B").End(xlUp).Row
    Sheets("New").Range("A3:A" & lr) = Sheets("New").Range("A2")

End Sub
Click to expand...
 
Upvote 0
Code: 
Private Sub CommandButton3_Click()

    Set copySheet = Worksheets("Sheet1")
    Set pasteSheet = Worksheets("New")

    Application.ScreenUpdating = False

    With copySheet
        .Columns("C:C").Sort Key1:=.Range("C:C"), Order1:=xlDescending, Header:=xlYes

        .Range(.Cells(2, "C"), .Cells(.Cells(Rows.Count, "C").End(xlUp).Row, "C")).Copy
        pasteSheet.Cells(2, 2).PasteSpecial xlPasteValues
        Range("B2", Range("B2").End(xlDown)).NumberFormat = "0"

        .Range(.Cells(2, "F"), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, "F")).Copy
        pasteSheet.Cells(2, 33).PasteSpecial xlPasteValues

        .Range(.Cells(2, "F"), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, "F")).Copy
        pasteSheet.Cells(2, 34).PasteSpecial xlPasteValues

        .Range(.Cells(2, "L"), .Cells(.Cells(Rows.Count, "L").End(xlUp).Row, "L")).Copy
        pasteSheet.Cells(2, 8).PasteSpecial xlPasteValues

        .Range(.Cells(2, "M"), .Cells(.Cells(Rows.Count, "M").End(xlUp).Row, "M")).Copy
        pasteSheet.Cells(2, 19).PasteSpecial xlPasteValues

        .Range(.Cells(2, "Q"), .Cells(.Cells(Rows.Count, "Q").End(xlUp).Row, "Q")).Copy
        pasteSheet.Cells(2, 17).PasteSpecial xlPasteValues
    End With


    With Range("Q2", Range("Q" & Rows.Count).End(xlUp))
        .EntireColumn.Insert
        .NumberFormat = "@"
        With .Offset(, -1)
            .FormulaR1C1 = "=Text(RC[1],""dd/mm/YYYY"")"
            .Offset(, 1).Value = .Value
            .EntireColumn.Delete
        End With
    End With

    lr = Sheets("New").Cells(Rows.Count, "B").End(xlUp).Row
    Sheets("New").Range("A3:A" & lr) = Sheets("New").Range("A2")

    Application.ScreenUpdating = True
End Sub

Btw, I suspect that it isn't really what you want but we will take it from there (and if it isn't thinking ahead is there any one of the columns that only has a header row the first time that the code is run?)
 
Last edited:
Upvote 0
hi this is working great now much more smoother as before there was a few second delay but now it is instant. thank you, is that because I did everything separately? I am still learning this your help is much appreciated
 
Upvote 0
No it is running smoother because I moved the Application.ScreenUpdating = False.
 
Upvote 0
Aww ok thank you. Why did that cause it to run slow? Is it always best to put where it is now? Thank you
 
Upvote 0
Turning off Sceenupdating literally stops you seeing the sheet update, any interaction with the sheet slows down code and so you turn it off at the earliest point when you don't need to see the interaction. 95% of the time this is at the start.
 
Upvote 0
aww okay thanks for letting me know much appreciated and thanks for all your advise and help much appreciated
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
706
Joe4
Joe4
T
  • Question
This is so slow I have to run it overnight
Replies
4
Views
237
kevin9999
K
R
  • Solved
Update Cell if Source Workbook or Source Worksheet is Missing
Replies
7
Views
219
rlv01
R
F
  • Solved
Simplifying a code
Replies
6
Views
252
MARK858
MARK858
O
  • Solved
VBA AutoFilter
2
Replies
19
Views
399
OX_2005
O

Forum statistics

Threads
1,214,653
Messages
6,120,750
Members
448,989
Latest member
mariah3

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
Back
Top