Hi. I have a macro which does the job I ask of it but I'd be grateful if anyone here could advise on how to speed it up. It's basically a find and replace on around 370,000 cells (1600 rows by 230 columns). I ran it on a subset and it took a bit under half an hour to do 46 columns. For all I know, this is as fast as it will go and it's not really a major problem, I can just go and make a cup of tea, or two, but I'd be interested to know if anything I've done is particularly cumbersome or contributing to its efficiency. (I picked up a useful tip on this site on turning on manual calculation.)
To sum up what I'm doing, each of the 1600 cells in each column is linked to the value of a cell in another file. Each column is linked to a different file but the cell references are the same so the macro just copies the 'link' formulae across all 230 columns and then replaces the file name in each. It may not be an ideal starting point but that's what I've inherited.
Sub ReplaceLAnumbers()
Dim i As Integer
Dim LAno, startLAno As String
Dim lastcol As Long
Dim xlCalc As XlCalculation
' Turns on manual calculation to speed things up.
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
' This macro will run through all LAs on active sheet and update links appropriately.
' Make sure that LA numbers of respondents are pasted in first row and that the
' link formulae are correct for the first LA (in third column).
Application.ScreenUpdating = False
' Identifies first LA number to be replaced in other columns.
startLAno = ActiveSheet.Cells(1, 3).Text
' If startLAno <100 then insert leading zero(s).
If Len(startLAno) = 1 Then
startLAno = "00" & startLAno
ElseIf Len(LAno) = 2 Then
startLAno = "0" & startLAno
End If
' Finds last column (LA) with data
lastcol = 3
Do Until ActiveSheet.Cells(1, lastcol).Value = ""
lastcol = lastcol + 1
Loop
lastcol = lastcol - 1
' Copies formula from first LA to all others
Range(Cells(6, 3), Cells(1604, 3)).Copy Destination:= _
Range(Cells(6, 4), Cells(1604, lastcol))
' Main loop for replacing each LA number
For i = 4 To lastcol
LAno = ActiveSheet.Cells(1, i).Text
' If LAno <100 then insert leading zero(s).
If Len(LAno) = 1 Then
LAno = "00" & LAno
ElseIf Len(LAno) = 2 Then
LAno = "0" & LAno
End If
' Amend range as necessary.
Range(Cells(6, i), Cells(1604, i)).Replace What:=startLAno, Replacement:=LAno, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalc
CalcBack:
Application.Calculation = xlCalc
End Sub
Display More