Tidying/Amending code

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,259
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
 
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




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

Forum statistics

Threads
1,224,824
Messages
6,181,186
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

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