Is There A Faster Way To Do This?

[CaliKidd]

I am using Excel 2007 and the following code to find blank/empty cells in a large column of data. If blanks exist, I use a variable to count the number of them and I highlight the cell using a sub.

The problem is this loop is slow because it requires every cell to be scanned. Is there a faster way, perhaps using a range object, variant array, find, intersect/union, etc? Unfortunately, I am not well-versed in these so I need some assistance.

For reasons I won't elaborate on, I do not want to use a conditional formatting solution.

For Each Scanned_Cell In Range("A5:A1000000")
[INDENT]Scanned_Cell.Select
If Len(Trim(Scanned_Cell)) = 0 Then
[INDENT]Scanned_Cell.Select
Call Highlight_Cell
Blanks = Blanks + 1
[/INDENT]End If
[/INDENT]Next

Also, instead of finding blank cells, what mods would be required if I wanted to:
1. Assuming the data is numeric, find any cell with a specific value (e.g., 0 (zero))?
2. Assuming the data is numeric, find any cell with a value greater than a certain number (e.g., > 1)?
3. Assuming the data is string, find any cell that is not equal to the letter "A", "B" or "C"?

Thanks in advance.

 

[RoryA]

I'm using a Core2 Duo 3.0GHz with only 2GB RAM.
FWIW, I just ran the below autofilter code without any sorting and it performed better than expected:

Sub AutofilterValues()
   Dim x
   Dim n                 As Long
   Dim lngRowCount       As Long
   Dim rng               As Range
   Dim strOut            As String
   Dim strAdd            As String
   Dim lngColour         As Long
   Dim ChunkSize       As Long
   Dim lngCounter As Long
   
   ChunkSize = 16000

   lngColour = 3
   Application.ScreenUpdating = False
   Set rng = Range("A4:A1000000")
   lngRowCount = rng.Rows.Count
   rng.AutoFilter 1, ""
   On Error Resume Next
   For n = rng.Row + 1 To lngRowCount Step ChunkSize
      If lngRowCount - n < ChunkSize Then ChunkSize = lngRowCount - n
      With Cells(n, "A").Resize(ChunkSize).SpecialCells(xlCellTypeVisible)
         .Interior.ColorIndex = lngColour
         lngCounter = lngCounter + .Count
      End With
   Next n
   rng.AutoFilter
   Debug.Print lngCounter & " cells coloured"
   Application.ScreenUpdating = True
End Sub

Times for 3 runs:
Total: 34.06184
Average: 11.35393
Max: 11.36190

Should be fairly simple to adapt for any criteria you can use with autofilter.

 

[RoryA]

I'm using a Core2 Duo 3.0GHz with only 2GB RAM.
FWIW, I just ran the below autofilter code without any sorting and it performed better than expected:

Sub AutofilterValues()
   Dim x
   Dim n                 As Long
   Dim lngRowCount       As Long
   Dim rng               As Range
   Dim strOut            As String
   Dim strAdd            As String
   Dim lngColour         As Long
   Dim ChunkSize       As Long
   Dim lngCounter As Long
   
   ChunkSize = 16000

   lngColour = 3
   Application.ScreenUpdating = False
   Set rng = Range("A4:A1000000")
   lngRowCount = rng.Rows.Count
   rng.AutoFilter 1, ""
   On Error Resume Next
   For n = rng.Row + 1 To lngRowCount Step ChunkSize
      If lngRowCount - n < ChunkSize Then ChunkSize = lngRowCount - n
      With Cells(n, "A").Resize(ChunkSize).SpecialCells(xlCellTypeVisible)
         .Interior.ColorIndex = lngColour
         lngCounter = lngCounter + .Count
      End With
   Next n
   rng.AutoFilter
   Debug.Print lngCounter & " cells coloured"
   Application.ScreenUpdating = True
End Sub

Times for 3 runs:
Total: 34.06184
Average: 11.35393
Max: 11.36190

Should be fairly simple to adapt for any criteria you can use with autofilter.

 

[CaliKidd]

Hey guys,

Thanks for your latest replies. I was out of commission for a day doing family stuff, so I need to catch up and try out your latest solutions.

Rory, I did try yours and obtained slightly faster results, but I am using Excel 2007 on a PC running Win7 64-bit, with I7 processor overclocked to 4Ghz with 6Gb RAM. More importantly, though, I found a bug.

The following line:

      If lngRowCount - n < ChunkSize Then ChunkSize = lngRowCount - n

needs to be changed to:

      If lngRowCount - n < ChunkSize Then ChunkSize = lngRowCount - n + 4

Mirabeau and Peter,
Sorry, I didn't actually clock your codes. I just ran them to see if they ran acceptably fast or slow. They were both fast, but I didn't quantify it in seconds. I will try to do so later if I have time. IMHO, whether it's 5 seconds or 9 seconds, that's pretty **** good in my book considering my VBA loop was taking minutes!

 

[CaliKidd]

OK, guys, on the topic of finding blank cells, I ran some test times for the proverbial record using a range A4:A1048576 with only one blank cell in the second to last cell. I made slight modifications to your code(s) in order to accommodate this larger range.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
Any ways, here are the results:<o></o>
<o> </o>
On a sunny day, 91 degrees F (33 C) outside with a light breeze blowing out of the Northwest, 32 oz of coffee (~ 1 liter) flowing through my veins, and Boston's "More Than A Feeling" cranking at about 100 decibels <?xml:namespace prefix = v ns = "urn:schemas-microsoft-com:vml" /><v:shapetype id=_x0000_t75 stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600"><v:stroke joinstyle="miter"></v:stroke><v:formulas><v:f eqn="if lineDrawn pixelLineWidth 0"></v:f><v:f eqn="sum @0 1 0"></v:f><v:f eqn="sum 0 0 @1"></v:f><v:f eqn="prod @2 1 2"></v:f><v:f eqn="prod @3 21600 pixelWidth"></v:f><v:f eqn="prod @3 21600 pixelHeight"></v:f><v:f eqn="sum @0 0 1"></v:f><v:f eqn="prod @6 1 2"></v:f><v:f eqn="prod @7 21600 pixelWidth"></v:f><v:f eqn="sum @8 21600 0"></v:f><v:f eqn="prod @7 21600 pixelHeight"></v:f><v:f eqn="sum @10 21600 0"></v:f></v:formulas><vath o:connecttype="rect" gradientshapeok="t" o:extrusionok="f"></vath><o:lock aspectratio="t" v:ext="edit"></o:lock></v:shapetype>, I obtained the following results:<o></o>
<o></o>
Mirabeau's code: 13.477, 13.477, 13.512 secs<o></o>
Peter's code: 27.531, 27.875, 27.953 secs<o></o>
Rory's code: 13.980, 13.961, 14.012 secs<o></o>
Rick's code: 0.059, 0.063, 0.066 secs <o></o>
My original code: 78.751 secs

I cannot say for sure, but I would speculate that the execution time could be influenced largely by various factors: hardware configuration, operating system, Excel version, and the data itself (number and position of blanks).

Whatever the case may be, one thing is certain: The blank cells are tired of being repeatedly profiled, segregated, counted and painted red. They want to be left alone now... or maybe that's the side-effect of too much caffeine speaking?

I'm now moving on to try the other solutions to 1, 2 and 3. More on those results later.

 

[RoryA]

Nowhere near enough coffee.

 

[CaliKidd]

hey Calikid,

To highlight all the zeros in ColA, try the following code, which took under two seconds on my computer to do the job.

Sub hilitezeros() 
Dim t#
t = Timer
Dim e As Range, a As Range, ang As String
Dim stg, x&, k&, p&, nr&
Set e = Range("A1")
nr = e(Rows.Count).End(3).Row
Set a = Range(e, e(nr))
stg = 0
...

I'm having a brain cramp here. Must be the inevitable coffee crash.

Questions:
1. What changes would be needed if the data starts in cell A4? If I just change "Set e = Range("A1")" to "Set e = Range("A4")", it chokes on the next line (object-defined error). I cannot debug it because I do not understand what exactly the object "e" is meant to represent?
2. The line "nr = e(Rows.Count).End(3).Row" calculates the last row of the dataset, but what, exactly, does the .End(3) part do? I'm familiar with arguments like xlDown, but I'm not familiar with that enumeration value "3" and couldn't find an explanation in the help file.

Of course easily extended to any value or string, not just zero.

So, back to the problems I labelled #1, #2, and #3, this matching sub would solve #1 (find a specific value), but not #2 (find all cells with a value > another value), correct?

As for #3, since I am trying to find all cells that do NOT match certain letters, would using the match approach work? If so, what, exactly, would I assign to stg?

PeterSS, I haven't tried your approach yet.

 

[CaliKidd]

Actaully, not sure why I was using a text value.
Changing
b(i, 1) = "#"
to
b(i, 1) = 0
in the codes in my previous post saves approximately 1/3 to 1/2 second for me.

Peter, I'm showing my ignorance again. For my general knowledge, what does the "#" and "0" represent? Once I understand this, it might make it clear why using "0" is faster than using "X".

Also, were you suggesting to make this change for ALL of those conditional scenarios or just one/some?

 

[gregtx81]

Here's another version to count and highlight cells of variable lengths. As is, the count formula only works for non-numbers (strings & blanks).

When counting cells of length=0, the variable 'OnlyTrulyEmptyCells' needs to be addressed. When false, the count will include cells with null values-- it's not restricted to truly empty cells. To count only empty cells, having results akin to SpecialCells(xlCellTypeBlanks) or IsBlank()=true, set to true.

Sub Macro1()
    
    Dim t#
    t = Timer

    
    Dim r As Range 'range searching
    Dim lengthSearch As Integer 'cell length searching for
    Dim ct As Long  'count of cells whose length=lengthSearch
    Dim OnlyTrulyEmptyCells As Boolean  'applicable when len=0...false=nulls are counted ,true=null values excluded from count
    
    '-----variables to set--------------------------
    '-----------------------------------------------
    lengthSearch = 0
    Set r = ActiveSheet.Range("A4:A1000000")
    OnlyTrulyEmptyCells = False
    '-----------------------------------------------
    

    r.FormatConditions.Delete
    r.Cells(1).Select           'seems to be required for FormatConditions
    
    If lengthSearch > 0 Or OnlyTrulyEmptyCells = False Then
        r.FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=LEN(TRIM(" & WorksheetFunction.Substitute(r.Cells(1).Address, "$", "") & "))=" & lengthSearch
    Else
        r.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=COUNTA(" & WorksheetFunction.Substitute(r.Cells(1).Address, "$", "") & ")=0"
    End If
    r.FormatConditions(r.FormatConditions.Count).SetFirstPriority
    
    With r.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    r.FormatConditions(1).StopIfTrue = False
    
    If lengthSearch > 0 Or OnlyTrulyEmptyCells = False Then
        ct = WorksheetFunction.CountIf(r, WorksheetFunction.Rept("?", lengthSearch))
    Else
        ct = r.Cells.Count - Evaluate("=COUNTA(" & r.Address & ")")
    End If
 
    
       MsgBox "Code took " & Format(Timer - t, "0.00 secs") & Chr(10) & _
    Chr(10) & "Count = " & ct

End Sub

 

[HarryS]

This seems like a popular game... I may join with a more versatile routine
which does similar and other jobs .. maybe not as fast but at reasonable speed
Of course send "" as the lookfor and xlwhole to deal with blanks

Private Sub CommandButton1_Click()
    FindAndColor "a6", 12, xlPart, 5, -1
    ' for column A, at row 6,  find 12 in any part Str or number, color it blue(5),  remove colors
    FindAndColor "B12", "daf", xlPart, 3
    'starting down from B12  find "daf" anywhere  color it red(3)  leave other colors
    FindAndColor "C2", 87, xlWhole, 4
    ' down from  C2 , find, 87, ignore 870 and fred87 's , color green(4) , default is to leave colors
    FindAndColor "AE150", "yt", xlPart, 4
    FindAndColor "A4:B31", 12, xlWhole, 18, 0, False
    ' in range A4:B31 , find 12 as whole, color it color index 18( brown) , leave other colors
    FindAndColor "Testr", 11, xlPart, 3, 4, False
    ' in the range testr find any 11 color it red(3)  , remove any green(4) color
End Sub
Sub FindAndColor(n$, LookFor, atLook As XlLookAt, ColIndex%, _
                 Optional ClearColor% = 0, Optional DoDown As Boolean = True)
    Dim RowsToDo As Long, CountC As Long, RRow&, RCol&, WCell
    Dim AWs As Worksheet, Ra As Range, FoundCell As Range, FRa$
    Set AWs = ActiveSheet
    Set Ra = Range(n)
    Application.ScreenUpdating = False
    If DoDown Then    ' else n is a named range
        RRow = Ra.Row
        RCol = Ra.Column
        RowsToDo = Range(Cells(RRow, RCol), Cells(Rows.Count, RCol).End(xlUp)).Rows.Count
        Set Ra = Ra.Resize(RowsToDo)
    End If
    ' clearcolor as integer so as to allow other clear color  options
    If ClearColor = -1 Then Ra.Cells.Interior.ColorIndex = xlNone
    'clearcolor 0 does nothing
    If ClearColor > 0 And ClearColor < 50 Then
        'get rid of one only color index
        For Each WCell In Ra.Cells
            If WCell.Interior.ColorIndex = ClearColor Then
                WCell.Interior.ColorIndex = xlNone
            End If
        Next WCell
    End If
     With Ra
        Set FoundCell = .Find(LookFor, LookIn:=xlValues, lookat:=atLook)
        If Not FoundCell Is Nothing Then
            FRa = FoundCell.Address
            Do
                FoundCell.Interior.ColorIndex = ColIndex
                CountC = CountC + 1
                Set FoundCell = .FindNext(FoundCell)
            Loop While Not FoundCell Is Nothing And FoundCell.Address <> FRa
        End If
    End With
   Application.ScreenUpdating = True
    MsgBox CountC & " cells in " & n
End Sub

 

[CaliKidd]

Thanks for your ideas, Greg and Harry. It's good to have even more options to evaluate.

To all,

I ran into a little bug, I mean "feature", of the autofilter. If I am filtering for a specific value (e.g., "=0"), it will work as long as the cell is formatted as a general, text or number cell with zero decimals, but it will NOT work if the cell is formatted as currency (e.g., $0), percent (0%), or a number with any decimal places (e.g., 0.0, 0.00, etc.).

So, if I want to filter for $0.00, then the autofilter must be "=$0.00" exactly. It will not trap $0. I haven't tried, but it may not even catch other currency symbols.

It seems the autofilter is format sensitive when trying to find a specific value.

Anyone encounter this and know of a way to resolve this autofilter quirk?

And here's the weirdest part: If I am filtering based on an expression (e.g., "< 0"), then it will find ALL negative values regardless of format, whether it is -1, -$1, -$1.00, etc. So, in that case, it is NOT format-sensitive.

{Cue in the "Twilight Zone" theme music.}