Help with making code run faster

[greyangel]

I am using the code below to sort through a massive amount of data (>50,000 lines.) The code below works but it takes about 15-20 minutes to run and I was wondering if there were any secrets that make it run faster.

Cells.AutoFilter

Range("f" & Rows.Count).End(xlUp).EntireRow.Interior.Color = 49407

Cells.Find(What:="LIFO Pool", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=True).Select
ActiveCell.Offset(1).Select

pool = ActiveCell.Value
vend = ActiveCell.Offset(, 1).Value

Do Until ActiveCell.Value = "" And ActiveCell.Interior.Color = 49407
'skips over cells that are grey and pink
If ActiveCell.Offset(, 1).Interior.Color <> 12632256 And ActiveCell.Interior.Color <> 8421631 Then
If ActiveCell.Value = "" Then
ActiveCell.Value = pool
ElseIf ActiveCell.Value <> "" Then
pool = ActiveCell.Value
End If

If ActiveCell.Offset(, 1).Value = "" Then
ActiveCell.Offset(, 1).Value = vend
ElseIf ActiveCell.Offset(, 1).Value <> "" Then
vend = ActiveCell.Offset(, 1).Value
End If
End If

If ActiveCell.Value = "" Then
ActiveCell.Value = pool
ElseIf ActiveCell.Value <> "" Then
pool = ActiveCell.Value
End If

Hierarchy = ActiveCell.Offset(, 2).Value
ActiveCell.Offset(, 2).Value = Hierarchy
ActiveCell.Offset(, -1).Value = ActiveCell.Value & ActiveCell.Offset(, 1).Value & ActiveCell.Offset(, 2).Value
ActiveCell.Offset(1).Select
Loop

[SamT]

First, stop using Interior.Color = Some RGB value.
Excel changes that RGB value to the closest match in the Cells Format ColorPicker dialog. (For example, on my machine, 49407 translates to an Orange, ColorIndex 44.) Then, when you ask it to check the Cell's interior.Color, it has to perform an RGB fucntion,Change the value to the nearest match, then compare.

If you use Interior.ColorIndex, then Excel just looks in a table. BTW, the ColorIndex of nearest shade of Grey to that RGB on my machine is 15. 8421631, a pink, ColorIndex is 22

Change the Address in this snippet to one of your 49407 colored cells and run

Sub t()

With Range("A1")
.Value = .Interior.ColorIndex
End With
End Sub

to find the actual ColorIndex Excel is using for that RGB value

You can make a table of all ColorIndices and matching hues with

Sub ColorIndices()
Dim i as long
With Range("A:A")
With .Cells(i)
.Value = i
.Interior.ColorIndex = i
End With
End With
Next

Second. Quit using "ActiveCell." Everytime VBA sees "ActiveCell" it has to look at he Worksheet to see which cell is currently active.

Dim Found as Range 'Don't skip using Found and Checking it for Nothing. That way lies madness!
Dim PoolCell As Range
Dim VendCell As Range

Set Found = [LIFOPoolColumn].Find(What:="LIFO Pool", LookIn:=xlFormulas _ 
, LookAt:=xlPart,  MatchCase:=False, SearchFormat:=True) 
'Are you sure about SearchFormat? I cannot see where you set up the prerequisites for using it.
'Edit [LIFOPoolColumn] to the Column Address, Ex(Range("Z:Z"))
'Hard to give perfect advice, since I can't see the worksheet
If Found is Nothing, then Exit Sub

set PoolCell = Found.Offset(1)
Set VendCell = PoolCell.Offset(, 1)

'Start loop
'Blah Edit all ActiveCell to PoolCell
'Blah Edit all ActiveCell.Offset(, 1) to VendCell
'blah
'blah

'At the botttom of the loop,
'Instead of ActiveCell.Offset(1).Select 
Set PoolCell = PoolCell.Offset(1)
Set VendCell = VendCell.Offset(1)
loop

[mdmackillop]

If you post a representative sample of your data that would help

[greyangel]

Example Reports.xlsm

If you post a representative sample of your data that would help

Here is a sample of my data. The macro is already in this spreadsheet and is labeled "Testthis." I had to modify my code a little due to the number of columns I actually created in the "sample" document.

[greyangel]

First, stop using Interior.Color = Some RGB value.
Excel changes that RGB value to the closest match in the Cells Format ColorPicker dialog. (For example, on my machine, 49407 translates to an Orange, ColorIndex 44.) Then, when you ask it to check the Cell's interior.Color, it has to perform an RGB fucntion,Change the value to the nearest match, then compare.

If you use Interior.ColorIndex, then Excel just looks in a table. BTW, the ColorIndex of nearest shade of Grey to that RGB on my machine is 15. 8421631, a pink, ColorIndex is 22

Change the Address in this snippet to one of your 49407 colored cells and run

Sub t()

With Range("A1")
.Value = .Interior.ColorIndex
End With
End Sub

to find the actual ColorIndex Excel is using for that RGB value

You can make a table of all ColorIndices and matching hues with

Sub ColorIndices()
Dim i as long
With Range("A:A")
With .Cells(i)
.Value = i
.Interior.ColorIndex = i
End With
End With
Next

Second. Quit using "ActiveCell." Everytime VBA sees "ActiveCell" it has to look at he Worksheet to see which cell is currently active.

Dim Found as Range 'Don't skip using Found and Checking it for Nothing. That way lies madness!
Dim PoolCell As Range
Dim VendCell As Range

Set Found = [LIFOPoolColumn].Find(What:="LIFO Pool", LookIn:=xlFormulas _ 
, LookAt:=xlPart,  MatchCase:=False, SearchFormat:=True) 
'Are you sure about SearchFormat? I cannot see where you set up the prerequisites for using it.
'Edit [LIFOPoolColumn] to the Column Address, Ex(Range("Z:Z"))
'Hard to give perfect advice, since I can't see the worksheet
If Found is Nothing, then Exit Sub

set PoolCell = Found.Offset(1)
Set VendCell = PoolCell.Offset(, 1)

'Start loop
'Blah Edit all ActiveCell to PoolCell
'Blah Edit all ActiveCell.Offset(, 1) to VendCell
'blah
'blah

'At the botttom of the loop,
'Instead of ActiveCell.Offset(1).Select 
Set PoolCell = PoolCell.Offset(1)
Set VendCell = VendCell.Offset(1)
loop

IF the LIFOpoolcolumn is column B how to I set that up in your found variable?

[Paul_Hossler]

I'm not following all the .Color testing logic (not even sure it's needed)

Try this --

WS Report 1 is your data
WS Original is a copy to re-init Report 1 after testing the macro
WS After is the results of your macro that I was using as a check

Option Explicit
Sub testthis_1()
    Dim rowLast As Range, rowFirst As Range, cellBlanks As Range
 
   Application.ScreenUpdating = False
    
    With Worksheets("Report 1")
        Set rowFirst = .Cells.Find(What:="LIFO Pool", After:=.Cells(1, 1), _
            LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=True)
        Set rowLast = .Cells(.Rows.Count, 2).End(xlUp).Offset(0, 1)
'        MsgBox rowFirst.Address & " -- " & rowLast.Address
        
        Set cellBlanks = Nothing
        On Error Resume Next
        Set cellBlanks = Range(rowFirst, rowLast).SpecialCells(xlCellTypeBlanks)
        If Not cellBlanks Is Nothing Then
            cellBlanks.Formula = "=R[-1]C"
            cellBlanks.Copy
            cellBlanks.PasteSpecial (xlPasteValues)
        End If
        
        Set rowFirst = rowFirst.Offset(1, -1)
        Set rowLast = rowLast.Offset(0, -2)
'        MsgBox rowFirst.Address & " -- " & rowLast.Address
        Range(rowFirst, rowLast).Formula = "=RC[1] & RC[2] & RC[3]"
        Range(rowFirst, rowLast).Copy
        Range(rowFirst, rowLast).PasteSpecial (xlPasteValues)
    End With
 
   Application.ScreenUpdating = True
End Sub

[greyangel]

Paul and Sam you both are geniuses, however I did forget one thing the bit of code below is used to eliminate all zeros in front of the first number in column D. For example I have a cell that says "0201002" this is stored as text in the original file I need this to actually shw "201002"

Hierarchy = ActiveCell.Offset(, 2).Value 
    ActiveCell.Offset(, 2).Value = Hierarchy

Sam I tried your code with the added details below and it still returned the "0201002" number

Set Hierarchy = poolcell.offset(,2).value
Poolcell.offset(,2).value = Hierarchy

[greyangel]

I'm not following all the .Color testing logic (not even sure it's needed)

Try this --

WS Report 1 is your data
WS Original is a copy to re-init Report 1 after testing the macro
WS After is the results of your macro that I was using as a check

Option Explicit
Sub testthis_1()
    Dim rowLast As Range, rowFirst As Range, cellBlanks As Range
 
   Application.ScreenUpdating = False
    
    With Worksheets("Report 1")
        Set rowFirst = .Cells.Find(What:="LIFO Pool", After:=.Cells(1, 1), _
            LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=True)
        Set rowLast = .Cells(.Rows.Count, 2).End(xlUp).Offset(0, 1)
'        MsgBox rowFirst.Address & " -- " & rowLast.Address
        
        Set cellBlanks = Nothing
        On Error Resume Next
        Set cellBlanks = Range(rowFirst, rowLast).SpecialCells(xlCellTypeBlanks)
        If Not cellBlanks Is Nothing Then
            cellBlanks.Formula = "=R[-1]C"
            cellBlanks.Copy
            cellBlanks.PasteSpecial (xlPasteValues)
        End If
        
        Set rowFirst = rowFirst.Offset(1, -1)
        Set rowLast = rowLast.Offset(0, -2)
'        MsgBox rowFirst.Address & " -- " & rowLast.Address
        Range(rowFirst, rowLast).Formula = "=RC[1] & RC[2] & RC[3]"
        Range(rowFirst, rowLast).Copy
        Range(rowFirst, rowLast).PasteSpecial (xlPasteValues)
    End With
 
   Application.ScreenUpdating = True
End Sub

Paul the color logic was meant to tell excel when to stop and what lines to copy down. Your code accomplishes the same thing just a lot faster without the color index.

[Aflatoon]

First, stop using Interior.Color = Some RGB value.
Excel changes that RGB value to the closest match in the Cells Format ColorPicker dialog. (For example, on my machine, 49407 translates to an Orange, ColorIndex 44.) Then, when you ask it to check the Cell's interior.Color, it has to perform an RGB fucntion,Change the value to the nearest match, then compare.

If you use Interior.ColorIndex, then Excel just looks in a table. BTW, the ColorIndex of nearest shade of Grey to that RGB on my machine is 15. 8421631, a pink, ColorIndex is 22

Of course, that is only true for Excel 2003 and older.

[Paul_Hossler]

Paul and Sam you both are geniuses, however I did forget one thing the bit of code below is used to eliminate all zeros in front of the first number in column D. For example I have a cell that says "0201002" this is stored as text in the original file I need this to actually shw "201002"

Change the one line andsee if it works

        Range(rowFirst, rowLast).Formula = "=RC[1] & RC[2] & IF(ISERROR(NUMBERVALUE(RC[3])),RC[3],NUMBERVALUE(RC[3]))"

[SamT]

IF the LIFOpoolcolumn is column B how to I set that up in your found variable?

Set Found = Range("B"B").Find(What:="LIFO Pool", LookIn:=xlFormulas _ 
, LookAt:=xlPart,  MatchCase:=False, SearchFormat:=True)

[greyangel]

[QUOTE=Paul_Hossler;365928]

Paul and Sam you both are geniuses, however I did forget one thing the bit of code below is used to eliminate all zeros in front of the first number in column D. For example I have a cell that says "0201002" this is stored as text in the original file I need this to actually shw "201002"

Change the one line andsee if it works

        Range(rowFirst, rowLast).Formula = "=RC[1] & RC[2] & IF(ISERROR(NUMBERVALUE(RC[3])),RC[3],NUMBERVALUE(RC[3]))"

I used your code and added a few lines of code to the very beginning.

Option Explicit
Sub testthis_1()
Application.screenupdating = false
Columns("D:D").TextToColumns Destination:=Columns("D:D"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 1), TrailingMinusNumbers:=True
    Dim rowLast As Range, rowFirst As Range, cellBlanks As Range
    
    With Worksheets("P555021 - Matched Summary")
        Set rowFirst = .Cells.Find(What:="LIFO Pool", After:=.Cells(1, 1), _
            LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=True)
        Set rowLast = .Cells(.Rows.Count, 2).End(xlUp).Offset(0, 1)
'        MsgBox rowFirst.Address & " -- " & rowLast.Address
        
        Set cellBlanks = Nothing
        On Error Resume Next
        Set cellBlanks = Range(rowFirst, rowLast).SpecialCells(xlCellTypeBlanks)
        If Not cellBlanks Is Nothing Then
            cellBlanks.Formula = "=R[-1]C"
            cellBlanks.Copy
            cellBlanks.PasteSpecial (xlPasteValues)
        End If
        
        Set rowFirst = rowFirst.Offset(1, -1)
        Set rowLast = rowLast.Offset(0, -2)
'        MsgBox rowFirst.Address & " -- " & rowLast.Address
        Range(rowFirst, rowLast).Formula = "=RC[1] & RC[2] & IF(ISERROR(NUMBERVALUE(RC[3])),RC[3],NUMBERVALUE(RC[3]))"
        Range(rowFirst, rowLast).Copy
        Range(rowFirst, rowLast).PasteSpecial (xlPasteValues)
    
    
    
    End With
    
    
    Application.ScreenUpdating = True
End Sub

[SamT]

@ Aflatoon,
In later version is checking cells for RGB values as fast as checking for ColorIndices? I just :

[SamT]

I have a cell that says "0201002" this is stored as text in the original file I need this to actually shw "201002"

Assuming no Alpha characters in Value and that the value is always numerically less than 2147483647;

Hierarchy = CStr(Clng(poolcell.offset(,2).value))

That assumes no (decimal) dots or commas in value. Else use

Hierarchy = CStr(CDbl(poolcell.offset(,2).value))

[Paul_Hossler]

I used your code and added a few lines of code to the very beginning.

And did it still work?

[greyangel]

And did it still work?

Yeah it worked like a charm. Also this code took less than a minute to run, I say job well done.

[Aflatoon]

@ Aflatoon,
In later version is checking cells for RGB values as fast as checking for ColorIndices? I just :

As far as I know. They aren't the same thing though, so the question is moot, in my opinion.