Sluggish excel after macro is run...

[shukero]

Hi everyone,

I have finally finished a macro which I use on several documents that come through. (This macro takes data from one sheet and pastes it into another sheet) the problem is, if I have a document with ~1000 or more lines, excel because EXTREMELY slow after I use this macro. To the point where it will not "Refresh" the cells when I enter new data, or even extend the cells out.

Here is the code I am using:

Sub Copy_Green_White_Cells_Creatives()
' This will copy any creative names that have either green or white fill into "Sheet1"
' and will then paste them as "Values"
'
Application.ScreenUpdating = False

Dim count As Integer

With Worksheets("AD-Creative Direction")

For x = 4 To .Cells(Rows.count, 3).End(xlUp).Row
' Find all cells in column 3 (C) to the end of my data

ConditionalColor = Worksheets("AD-Creative Direction").Cells(x, 3).Interior.ColorIndex
' Macro is checking column 3 for Specific color(s)

    If ConditionalColor = xlNone Or ConditionalColor = 14 And .Cells(x, 3) > "" Then
    ' If "Fill" in Cells are 14 (Green) or xlNone (No Fill) and they have data... copy them to "Sheet 1"

        .Cells(x, 1).Copy
        Worksheets("Sheet1").Cells(1 + count, 1).PasteSpecial xlPasteValues
        .Cells(x, 2).Copy
        Worksheets("Sheet1").Cells(1 + count, 2).PasteSpecial xlPasteValues
        .Cells(x, 3).Copy
        Worksheets("Sheet1").Cells(1 + count, 3).PasteSpecial xlPasteValues
        count = count + 1
        End If
    Next x
End With

Application.ScreenUpdating = True

End Sub

Is there anyway to "refresh" excel, so it isn't bogging down? I'm completely open to re-writing the code with some help from the Excel VBA Gurus of this forum.

Thanks,
~Mike

 

[hiker95]

shukero,

In a copy of your workbook, add the following bold code line, and, then test the updated macro.

    If ConditionalColor = xlNone Or ConditionalColor = 14 And .Cells(x, 3) > "" Then
    ' If "Fill" in Cells are 14 (Green) or xlNone (No Fill) and they have data... copy them to "Sheet 1"

        .Cells(x, 1).Copy
        Worksheets("Sheet1").Cells(1 + Count, 1).PasteSpecial xlPasteValues
        .Cells(x, 2).Copy
        Worksheets("Sheet1").Cells(1 + Count, 2).PasteSpecial xlPasteValues
        .Cells(x, 3).Copy
        Worksheets("Sheet1").Cells(1 + Count, 3).PasteSpecial xlPasteValues
        Count = Count + 1
        
        Application.CutCopyMode = False
        
    End If

 

[mumps]

Try:

Sub CopyCells()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("AD-Creative Direction").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    For Each rng In Sheets("AD-Creative Direction").Range("C4:C" & LastRow)
        If rng <> "" Then
            If rng.Interior.ColorIndex = 14 Or rng.Interior.ColorIndex = xlNone Then
                Sheets("AD-Creative Direction").Cells(rng.Row, "AX") = "True"
            Else
                Sheets("AD-Creative Direction").Cells(rng.Row, "AX") = "False"
            End If
        End If
    Next rng
    Sheets("AD-Creative Direction").Range("AX4:AX" & LastRow).AutoFilter Field:=1, Criteria1:="TRUE"
    Sheets("AD-Creative Direction").Range("A4:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy
    Sheets("Sheet1").Cells(Rows.count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    If Sheets("AD-Creative Direction").FilterMode Then Sheets("AD-Creative Direction").ShowAllData
    Sheets("AD-Creative Direction").Columns("AX").ClearContents
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

The macro uses column AX as a helper column so as long as you don't have data in column AX, the macro should work for you.