View Full Version : [SOLVED:] Help with making code run faster
greyangel
07-25-2017, 11:42 AM
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
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
07-25-2017, 02:39 PM
If you post a representative sample of your data that would help
greyangel
07-26-2017, 06:15 AM
19880
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
07-26-2017, 07:19 AM
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
07-26-2017, 07:20 AM
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
07-26-2017, 07:41 AM
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
07-26-2017, 07:47 AM
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
07-26-2017, 07:50 AM
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
07-26-2017, 08:11 AM
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]))"
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
07-26-2017, 10:05 AM
[QUOTE=greyangel;365922]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
@ Aflatoon,
In later version is checking cells for RGB values as fast as checking for ColorIndices? I just :dunno:
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
07-26-2017, 01:16 PM
I used your code and added a few lines of code to the very beginning.
And did it still work?
greyangel
07-26-2017, 01:22 PM
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. :thumb
Aflatoon
07-27-2017, 01:08 AM
@ Aflatoon,
In later version is checking cells for RGB values as fast as checking for ColorIndices? I just :dunno:
As far as I know. They aren't the same thing though, so the question is moot, in my opinion.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.