vba copy data every 10 minutes

[ste33uka]

I use the follwing vba to auto copy data from cells to cells every ten 10 minutes.
It runs for 70 sheets.
i have just added the 1st 2 sheets as an example.

Would there be anyway to make it copy faster ?
Would adding code in vba "if cell has value over >0" make it faster? , as some cells dont have data all the time.
Would anyone have an example how to add " if cell is over >0" ?
Thanks

Sub copytenminutes()
     Sheet1.Range("cd1").Value = Sheet1.Range("F5").Value
     Sheet1.Range("ce1").Value = Sheet1.Range("f6").Value
     Sheet1.Range("cf1").Value = Sheet1.Range("F7").Value
     Sheet1.Range("cg1").Value = Sheet1.Range("f8").Value
     Sheet1.Range("ch1").Value = Sheet1.Range("F9").Value
     Sheet1.Range("ci1").Value = Sheet1.Range("f10").Value
     Sheet1.Range("cj1").Value = Sheet1.Range("F11").Value
     Sheet1.Range("ck1").Value = Sheet1.Range("f12").Value
     Sheet1.Range("cl1").Value = Sheet1.Range("F13").Value
     Sheet1.Range("cm1").Value = Sheet1.Range("f14").Value
     Sheet1.Range("cn1").Value = Sheet1.Range("F15").Value
     Sheet1.Range("co1").Value = Sheet1.Range("f16").Value
     Sheet1.Range("cp1").Value = Sheet1.Range("F17").Value
     Sheet1.Range("cq1").Value = Sheet1.Range("f18").Value
     Sheet1.Range("cr1").Value = Sheet1.Range("F19").Value
    
     Sheet2.Range("cd1").Value = Sheet2.Range("F5").Value
     Sheet2.Range("ce1").Value = Sheet2.Range("f6").Value
     Sheet2.Range("cf1").Value = Sheet2.Range("F7").Value
     Sheet2.Range("cg1").Value = Sheet2.Range("f8").Value
     Sheet2.Range("ch1").Value = Sheet2.Range("F9").Value
     Sheet2.Range("ci1").Value = Sheet2.Range("f10").Value
     Sheet2.Range("cj1").Value = Sheet2.Range("F11").Value
     Sheet2.Range("ck1").Value = Sheet2.Range("f12").Value
     Sheet2.Range("cl1").Value = Sheet2.Range("F13").Value
     Sheet2.Range("cm1").Value = Sheet2.Range("f14").Value
     Sheet2.Range("cn1").Value = Sheet2.Range("F15").Value
     Sheet2.Range("co1").Value = Sheet2.Range("f16").Value
     Sheet2.Range("cp1").Value = Sheet2.Range("F17").Value
     Sheet2.Range("cq1").Value = Sheet2.Range("f18").Value
     Sheet2.Range("cr1").Value = Sheet2.Range("F19").Value

     Application.OnTime Now + TimeValue("00:10:00"), "copytenminutes"


End Sub

 

[rollis13]

Try adding at the begining of the macro:
Application.ScreenUpdating = False
and at the bottom just before Application.OnTime:
Application.ScreenUpdating = True
it may help.

 

[GWteB]

Try ...

Sub copytenminutes()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Sheet1
        .Range("cd1:cr1").Value = Application.Transpose(.Range("f5:f19").Value)
    End With
    With Sheet2
        .Range("cd1:cr1").Value = Application.Transpose(.Range("f5:f19").Value)
    End With

    Application.OnTime Now + TimeValue("00:10:00"), "copytenminutes"

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

 

[rollis13]

Since the sheets are 70 I would suggest changing these lines of code to something like this:

For Each Sht In Worksheets
    'if necessary add here exception/s with If/Then <> "Sheetname/s"
    With Sht
        .Range("CD1:CR1").Value = Application.Transpose(.Range("F5:F19").Value)
    End With
Next Sht

 

[ste33uka]

Thanks for all suggestions ,
and thanks gwteb, your suggestion made it super dooper fast.

​

 

[GWteB]

You are welcome!
Glad we could help and thanks for letting us know.

 

[ste33uka]

You are welcome!
Glad we could help and thanks for letting us know.

one more thing, i see what transpose does now, how would i auto copy ("f5:f19") to ("h5:h19"). ?

 

[ste33uka]

i worked it out. all done here

 

[ste33uka]

Thanks for all suggestions ,
and thanks gwteb, your suggestion made it super dooper fast.

​

How could i change code so that it pastes on next available row ?
So it would paste on row 1 cd1:cr1 then row 2 cd2:cr2 and ond so on ?

        Sub copytenminutes()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheet1
.Range("cd1:cr1").Value = Application.Transpose(.Range("f5:f19").Value)
End With
With Sheet2
.Range("cd1:cr1").Value = Application.Transpose(.Range("f5:f19").Value)
End With

Application.OnTime Now + TimeValue("00:10:00"), "copytenminutes"

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[rollis13]

Something like this will do the trick:

With sheet1
    lr = .Range("CD" & .Rows.Count).End(xlUp).Row + 1 'last used row +1
    .Range("CD" & lr & ":CR" & lr).Value = Application.Transpose(.Range("F5:F19").Value)
End With