My code is suddenly really slow

[Nititchandra77]

This code was working but not working now and it's really slow.

Sub automate_200324_loop()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Dim CellValue As String, rs As Worksheet, p As Integer, q As Integer

Dim cellValue1 As String, wb As Workbook: Set wb = ActiveWorkbook

Dim startName As String: startName = " "

Dim counter As Integer: counter = 1

Dim lastrow As Long, lastRow2 As Long, LastRow3 As Long, LastRow4 As Long, rgdata As Range

Dim lRow As Long, lColumn As Long, n As Integer




'Activate the omb file

Worksheets("OMB file").Activate


lColumn = Range("a1").CurrentRegion.Columns.Count

For n = 1 To lColumn Step 2

Sheets("OMB file").Columns.Copy Destination:=Sheets("Input OMB").Columns(1)

Sheets("OMB file").Columns(n + 1).Copy Destination:=Sheets("Input OMB").Columns(2)

Worksheets("Input OMB").Activate

Worksheets("Input OMB").Range("A1:a1").Copy

CellValue = Range("A1:a1").Value
Worksheets("DATA DICTIONARY").Activate

Rows(1).Select

Selection.Find(What:=CellValue, After:=ActiveCell, _
LookIn:=xlFormulas2, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate

ActiveCell.Select

ActiveCell.Offset(0, -1).Select

ActiveCell.Columns("A:B").EntireColumn.Select

Selection.Copy Destination:=Worksheets("Input CFW DD").Range("A1")
Application.CutCopyMode = False




Sheets("Final output").Range("a:f").Copy
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

ActiveSheet.Name = ActiveSheet.Range("e1")


Worksheets("OMB file").Range("ak1").Copy Destination:=ActiveSheet.Range("h1")

'1st Conditional format cells

ActiveSheet.Range("A1,A:A,d:d").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False


'Second conditional format

ActiveSheet.Range("b1,b:b,e:e").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
ActiveWorkbook.Save


lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).row

For p = 2 To lastrow

ActiveSheet.Select

'If Cells(p, 1).Interior.ColorIndex = -4142 Then
If Cells(p, 1).DisplayFormat.Interior.Color = 13551615 Then
Cells(p, 1).Offset(0, 2) = " "
Else: Cells(p, 1).Offset(0, 2) = " Update code/ Add new code and value"
End If

Next p

'170224
lastRow2 = ActiveSheet.Cells(ActiveSheet.Rows.Count, "d").End(xlUp).row

For q = 2 To lastRow2

ActiveSheet.Select


'If Cells(p, 1).Interior.ColorIndex = -4142 Then
If Cells(q, 4).DisplayFormat.Interior.Color = 13551615 Then
Cells(q, 4).Offset(0, 2) = " "
Else: Cells(q, 4).Offset(0, 2) = " Archive"
End If

Next q
Next n


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[RobP]

Hi, Presumably it is because your spreadsheet became quite large (in both columns and rows.

So for each column you have (in loop n), you are asking it to scroll through every line twice via loop p and q, and make some processing.
If you have 5000 rows and 20 columns, this is going to take some time !

I don't know how big your data is, but I imagine its getting steadily slower if you keep adding to it .... So I would try and see if you can find a way to remove at least one of the loops p and q, or make the processing they do a little less heavy. Easier said than done, as you are performing pretty slow tasks in changing cell formats.

For example, just to check - is the data in Col A the same size as data in Col D (I mean would LastRow be different to LastRow2 ?) If the data in both columns finish on the same row (LAstRow therefore = LastRow2) - why not just have 1 loop, and make it do all hte formatting in one go ?

Apart from that, maybe try deleting old data not needed before execution ?

Sorry thats all I have.

Rob