Simplify copy data to different worksheet

[shudson]

Hi All

I am new to macro's and therefore not sure how to do this quicker.

I found the following macro in another post that is very similar to what I want to do, however when I copied it over it takes a while to complete. Is there a simpler way to write this.

The revamped version of the macro that I found is

Sub test()
With Sheets("New")
.Range("B5").Copy Destination:=Sheets("Ongoing").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Range("C7").Copy Destination:=Sheets("Ongoing").Range("B" & Rows.Count).End(xlUp).Offset(1)
.Range("I6").Copy Destination:=Sheets("Ongoing").Range("C" & Rows.Count).End(xlUp).Offset(1)
.Range("B7").Copy Destination:=Sheets("Ongoing").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Range("C7").Copy Destination:=Sheets("Ongoing").Range("B" & Rows.Count).End(xlUp).Offset(1)
.Range("I6").Copy Destination:=Sheets("Ongoing").Range("C" & Rows.Count).End(xlUp).Offset(1)
.Range("B9").Copy Destination:=Sheets("Ongoing").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Range("C7").Copy Destination:=Sheets("Ongoing").Range("B" & Rows.Count).End(xlUp).Offset(1)
.Range("I6").Copy Destination:=Sheets("Ongoing").Range("C" & Rows.Count).End(xlUp).Offset(1)
.Range("B5:9,C7,I6").ClearContents
End With
Sheets("Ongoing").Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ThisWorkbook.Save
End Sub

What I have is different values will be entered into Cells B5, B7, B9 but the information that is entered into Cells C7 & I6 will go against all of the three different values.

eg.

B5 = 986 C7= Training I9=SYD
B7 = 689 C7= Training I9=SYD
B9 = 237 C7= Training I9=SYD


Fingers crossed this is able to be simplified and Thank you to those that can give assistance.

 

[Prense01]

Perhaps...

Sub test()
[COLOR=#000066]Application.[B]ScreenUpdating[/B] = False[/COLOR]
Application.[B]Calculation[/B] = xlCalculationManual
With Sheets("New")
.Range("B5").Copy Destination:=Sheets("Ongoing").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Range("C7").Copy Destination:=Sheets("Ongoing").Range("B" & Rows.Count).End(xlUp).Offset(1)
.Range("I6").Copy Destination:=Sheets("Ongoing").Range("C" & Rows.Count).End(xlUp).Offset(1)
.Range("B7").Copy Destination:=Sheets("Ongoing").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Range("C7").Copy Destination:=Sheets("Ongoing").Range("B" & Rows.Count).End(xlUp).Offset(1)
.Range("I6").Copy Destination:=Sheets("Ongoing").Range("C" & Rows.Count).End(xlUp).Offset(1)
.Range("B9").Copy Destination:=Sheets("Ongoing").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Range("C7").Copy Destination:=Sheets("Ongoing").Range("B" & Rows.Count).End(xlUp).Offset(1)
.Range("I6").Copy Destination:=Sheets("Ongoing").Range("C" & Rows.Count).End(xlUp).Offset(1)
.Range("B5:9,C7,I6").ClearContents
End With
Sheets("Ongoing").Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.[B]Calculation[/B] = xlCalculationAutomatic
[COLOR=#000066]Application.[B]ScreenUpdating[/B] = True[/COLOR]
ThisWorkbook.Save
End Sub

 

[AlphaFrog]

Sub test()
    Dim Lastrow As Long
    
    Lastrow = Sheets("Ongoing").Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    With Sheets("New")
        Sheets("Ongoing").Range("A" & Lastrow).Value = .Range("B5").Value
        Sheets("Ongoing").Range("A" & Lastrow + 1).Value = .Range("B7").Value
        Sheets("Ongoing").Range("A" & Lastrow + 2).Value = .Range("B9").Value
        Sheets("Ongoing").Range("B" & Lastrow).Resize(3).Value = .Range("C7").Value
        Sheets("Ongoing").Range("C" & Lastrow).Resize(3).Value = .Range("I6").Value
    End With

    Sheets("Ongoing").Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ThisWorkbook.Save
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Note:
ThisWorkbook.Save could take awhile if it's a large file