Can i quicken this Function or use diff code to speed it Up

[mahmed1]

Hi

I have this function that is used on several sheets and the The range to lookin is in B2:I200 therefore it loops several of times when this function is called or when a cell changes within that range on that sheet

I double on a cell to change its colour and add a value and then this function is called to sum the colour

This works fine but can be clunky at times

Need help speeding it up or using different method

Here is the working Code:

Function SumColour(MatchColour As Range, MatchColourRange) As Double
Dim Cell As Range
Application.ScreenUpdating = False
For Each Cell In MatchColourRange
    If Cell.Interior.Color = MatchColour.Interior.Color Then
        On Error Resume Next
        SumColour = SumColour + Cell.Value
        On Error GoTo 0
    End If
Next Cell
Application.ScreenUpdating = True
End Function

 

[Rick Rothstein]

Im trying to do the same thing as the function but replace with a sub so its called but with the find method to make it more quicker

How did you want to specify the two ranges that you now pass into your function? Is the color cell in a fixed location (if so, what is its address)? What about the range you are checking for color... is it a single column or single row (which)(if so, what is the starting cell address)?

 

[mahmed1]

Hi

i have 6 colours i check for

all colours are in a2 to a7 (i sum up each colour) in b2 to b7

the colour range to look and add is in d2 to AO100

This will be done the same for 4 sheets (say sheet1 to sheet4) all set up exactly the same

So look in all sheets
sum all colours for all sheets
in range d2 to AO100

 

[mahmed1]

Ps is this the best way you would recommend to do this also and would you advise the find instead of loop?

 

[Rick Rothstein]

i have 6 colours i check for

all colours are in a2 to a7 (i sum up each colour) in b2 to b7

the colour range to look and add is in d2 to AO100

This will be done the same for 4 sheets (say sheet1 to sheet4) all set up exactly the same

So look in all sheets
sum all colours for all sheets
in range d2 to AO100

Give this macro a try...

Sub CountColoredCells()
  Dim R As Long, Clr As Long, Total As Double
  Dim Rng As String, FirstAddress As String
  Dim SN As Variant, SheetNames As Variant
  Dim Cell As Range, WS As Worksheet
  Rng = "D2:AO100"
  
  SheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
  
  For Each SN In SheetNames
    Set WS = Sheets(SN)
    For R = 2 To 7
      Total = 0
      Clr = WS.Cells(R, "A").Interior.Color
      Application.FindFormat.Clear
      Application.FindFormat.Interior.Color = Clr
      With WS.Range(Rng)
        Set Cell = .Find("*", SearchFormat:=True)
        If Not Cell Is Nothing Then
          FirstAddress = Cell.Address
          Do
            Total = Total + Cell.Value
            Set Cell = .Find("*", Cell, SearchFormat:=True)
          Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
        End If
      End With
      WS.Cells(R, "B").Value = Total
    Next
  Next
  Application.FindFormat.Clear
End Sub

 

[mahmed1]

Hi Rick

was that enough info. If you need anymore please let me know

thank you

please ignore
just seen your post

 

[mahmed1]

Thank you

i will give that a go

it was the find format i was struggling with.

just a couple of questions

1) is this the best method rather than going down the function route?

2) why did you use the "*" and not "" (just curious)

3) just curious to why the find is quicker than the loop

 

[Rick Rothstein]

just a couple of questions

1) is this the best method rather than going down the function route?

2) why did you use the "*" and not "" (just curious)

3) just curious to why the find is quicker than the loop

1) Assuming you mean when the function is a UDF, I'm not sure... probably yes as long as you are willing to run it whenever you change something that affects one or more of the totals given that the Find method should be quicker than the basic loop method.

2) I believe specifying the asterisk force Find to look at cells with something in them during its search... without the asterisk, Find looks at all cells during its search.

3) The underlying loop Find uses to exclude cells that do not meet the specified criteria is done with highly optimized "pre-compiled" code... on the other hand, your loop executes individual VB functions for each cell in the range.

 

[mahmed1]

Thank you Rick

 

[mahmed1]

Hi Rick

I have just test and i get the subsript out of range error (I get it in the highlighted part in red). Ps can i change the array so that rather than it being sheet1, sheet2 etc hard coded. I refer to the sheets INDEX (A1:A4) which will hold the sheet names also

Dim R As Long, Clr As Long, Total As Double
Dim Rng As String, FirstAddress As String
Dim SN As Variant, SheetNames As Variant
Dim Cell As Range, WS As Worksheet
Rng = "D2:AO100"

SheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")

For Each SN In SheetNames
Set WS = Worksheets(SN)

 

[mahmed1]

Hi,

Just to confirm also that the sheets do exist

Thank You