Do Loop running slow

[pincivma]

Hi all

I wrote this simple code but it is taking a long time to run. Is there a faster running macro?

Range("BA9").Select
Do
ActiveCell.Select
If ActiveCell.HasFormula Then
ActiveCell.Select
Selection.Copy
ActiveCell.Offset(0, -48).Select
ActiveSheet.Paste
ActiveCell.Offset(0, 48).Select
End If
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell = "."

Thanks

 

[mole999]

you might consider testing to see if your offset already has a value
if you have formulas that are calculated after every worksheet change that will have an effect
how many rows are you working with

 

[pincivma]

OK. I will check things out. Thanks

 

[Fluff]

You can also get rid of all the selects like

With Range("BA9")
   i = 0
   Do
      If .Offset(i).HasFormula Then .Offset(i, -48).Value = .Offset(i).Value
      i = i + 1
   Loop Until .Offset(i) = "."
End With

 

[pincivma]

Thanks Fluff

I will give your code a try and see if it speeds up my macro.

 

[pincivma]

Hi Fluff

I finally had a chance to try your formula and I got an error on the line Loop Until .Offset(i) = ".". I also wanted formulas to remain formulas and not change into values. So I changed your macro to the following and it worked. Plus it took about 5 seconds to run the 11,000 rows. Thanks or the code.

With Range("BA9")
i = 0
Do
If .Offset(i).HasFormula Then .Offset(i, -48).formula = .Offset(i).formula
i = i + 1
Loop Until Until ActiveCell = "."
End With

 

[Fluff]

Glad you sorted it & thanks for the feedback

 

[footoo]

See if this is quicker :

Dim r As Range, rng As Range, a As Range
Set r = Range("BA9:BA" & Cells(Rows.Count, "BA").End(xlUp).Row).Find(".")(0)
On Error Resume Next
If Not r Is Nothing Then
    Set rng = Range("BA9:" & r.Address).SpecialCells(xlCellTypeFormulas)
Else: Set rng = Range("BA9:BA" & Cells(Rows.Count, "BA").End(xlUp).Row).SpecialCells(xlCellTypeFormulas)
End If
On Error GoTo 0
If Not rng Is Nothing Then
    For Each a In rng.Areas
        a.Copy a.Offset(0, -48)
    Next
End If