Tidying/Amending code

[Patriot2879]

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.

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

 

[MARK858]

So you just want it to paste in row 2 in the columns indicated by your code in post 1?

 

[Patriot2879]

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.

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

 

[MARK858]

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

 

[Patriot2879]

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

 

[MARK858]

No it is running smoother because I moved the Application.ScreenUpdating = False.

 

[Patriot2879]

Aww ok thank you. Why did that cause it to run slow? Is it always best to put where it is now? Thank you

 

[MARK858]

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.

 

[Patriot2879]

aww okay thanks for letting me know much appreciated and thanks for all your advise and help much appreciated