Speed Up Macro Code

[arrancollins1983]

Hi to all, this is my first time on here so please bear with me.
I have created the code below in Excel 2010 vba, the code itself works fine but due to it running through some 20,000 lines, I was wondering if anyone could help show me how I can speed this up?
I am sure, like most of you, I am self taugh with Excel VBA so any tips will be greatly recieved.
Code:
Sub Prop_List()
Dim Rng As Range, rCell As Range
Dim a As Long
Dim BL, SH, BE, RO, BU, FL, HO, MA, GA As String
a = Range("Data_Entry1").Value
b = Range("Data_Entry1").Value + 4
BL = "Block"
SC = "Scheme"
SH = "Shelter"
BE = "Bedsit"
RO = "Room"
BU = "Bungalow"
FL = "Flat"
HO = "House"
MA = "Maisonette"
GA = "Garage"
Application.ScreenUpdating = False

If a = 0 Then
MsgBox "No Data to Update", vbOKOnly
Exit Sub
Else

If Range("A1").Value = 1 Then

MsgBox "Property List Data already Updated", vbOKOnly
Exit Sub
Else
Application.StatusBar = True
Application.StatusBar = "Please wait... Data is being Updated"
Application.Cursor = xlWait
Rows("5:5").Select
Selection.Copy
Rows("5:5").Resize(a).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

Range("A1").Value = 1
Range("Data_Entry1").Offset(3, -4).Activate
Set Rng = Range("C5:C" & b)

For Each rCell In Rng.Cells
If InStr(1, rCell.Value, SC, vbTextCompare) Then rCell.Offset(0, 4).Value = SC
If InStr(1, rCell.Value, BL, vbTextCompare) Then rCell.Offset(0, 4).Value = BL
If InStr(1, rCell.Value, BE, vbTextCompare) Then rCell.Offset(0, 4).Value = BE
If InStr(1, rCell.Value, RO, vbTextCompare) Then rCell.Offset(0, 4).Value = RO
If InStr(1, rCell.Value, BU, vbTextCompare) Then rCell.Offset(0, 4).Value = BU
If InStr(1, rCell.Value, FL, vbTextCompare) Then rCell.Offset(0, 4).Value = FL
If InStr(1, rCell.Value, HO, vbTextCompare) Then rCell.Offset(0, 4).Value = HO
If InStr(1, rCell.Value, MA, vbTextCompare) Then rCell.Offset(0, 4).Value = MA
If InStr(1, rCell.Value, SH, vbTextCompare) Then rCell.Offset(0, 4).Value = SH
If InStr(1, rCell.Value, GA, vbTextCompare) Then rCell.Offset(0, 4).Value = GA
Next rCell
Range("Data_Entry1").Offset(4, 0).Resize(a).Select
Selection.Replace What:="", Replacement:="Other", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("Data_Entry1").Offset(3, -5).Select
Application.ScreenUpdating = True
Application.StatusBar = False
Application.Cursor = xlDefault
MsgBox "Data Update Complete"
End If
End If
End Sub

 

[tigeravatar]

arrancollins1983,

Give the following a try:

Sub Prop_List()
    
    Static a As Long: a = ActiveWorkbook.ActiveSheet.Range("Data_Entry1").Value
    
    If a = 0 Then
        MsgBox "No Data to Update", vbOKOnly
        Exit Sub
    End If
    
    If ActiveWorkbook.ActiveSheet.Range("A1").Value = 1 Then
        MsgBox "Property List Data already Updated", vbOKOnly
        Exit Sub
    End If
    
    With Application
        .ScreenUpdating = False
        .StatusBar = True
        .StatusBar = "Please wait... Data is being Updated"
        .Cursor = xlWait
    End With
    
    With ActiveWorkbook.ActiveSheet
        .Rows(5).Copy
        .Rows(5).Resize(a).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        
        Static Rng As Range:     Set Rng = .Range("C5:C" & a + 4)
        Dim arrData() As String: ReDim arrData(1 To Rng.Rows.Count)
        Dim arrWord() As String: arrWord = Split("Garage,Shelter,Maisonette,House,Flat,Bungalow,Room,Bedsit,Block,Scheme", ",")
        
        Dim rCell As Range
        Dim DataIndex As Long
        Dim WordIndex As Integer
        
        For Each rCell In Rng.Cells
            DataIndex = DataIndex + 1
            For WordIndex = 1 To UBound(arrWord)
                If InStr(1, rCell.Value, arrWord(WordIndex), vbTextCompare) > 0 Then
                    arrData(DataIndex) = arrWord(WordIndex)
                    Exit For
                End If
            Next WordIndex
        Next rCell
        Rng.Offset(0, 4).Value = WorksheetFunction.Transpose(arrData)
        
        .Range("Data_Entry1").Offset(4, 0).Resize(a).Replace What:="", Replacement:="Other"
        .Range("A1").Value = 1
    End With
    
    With Application
        .Cursor = xlDefault
        .StatusBar = False
        .ScreenUpdating = True
    End With
    
    MsgBox "Data Update Complete"
    
End Sub

 

[arrancollins1983]

Hi tigeravatar,

Thank you so much for this!! The macro completed in less than 2 seconds in comparison to 1 minute 25 seconds it took previously!!

This is greatly appreciated!!