Maximum size of a VBA Array - Excel 2007

[WebGenii]

Hi.
I'm just guessing here, but I notice your code constantly references ActiveCell. It might be worth setting a range object to this outside the loops (Set rng = ActiveCell).
If ActiveCell occurs within the loops then I assume that VBA has to constantly 'check in' with Excel to verify the ActiveCell. Andy.
(Then again, I might be completely wrong..)

My first small test does seem to show a small time gain by doing this.

[Jan Karel Pieterse]

Hi Webgenii,

Could you post the entire routine you have now? I expect it could be enhanced to run a lot faster.

[WebGenii]

Hi Webgenii,
Could you post the entire routine you have now? I expect it could be enhanced to run a lot faster.

I'd be delighted

Code: Select all

Sub CCBins()
Dim lngRowCount As Long, lngColCount As Long, lngBinCount As Long 'dimension counters
Dim varStatBar1 As Variant ' for status bar message
Dim BinArray 'hold bin values
Dim lngCCount As Long ' counter to move from column to column
Dim lngCounter As Long
Dim lngBinCounter As Long 'counter for moving through bins
Dim CurrentArray As Variant
Dim ArrayColourBins As Variant
Dim varValue As Variant
Dim varCheckBin As Variant 'compares array values
Dim myMin As Variant
Dim myMax As Variant
Dim dlStart As Double ' for timer start
Dim rngChroma As Range 'used in Find cells to colour them
Dim firstAddress As String
Dim SRangeAdds As String 'hold addresses of ranges
Dim Sheet As Worksheet
Dim xCell As Range
Dim RngStart As Range

dlStart = Timer

Application.Calculation = xlCalculationManual 'turn off calculation in the workbook.
Application.AutoRecover.Enabled = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

'count cells in Bin range to determine the number of bins
Range("bins").Select
lngBinCount = 0
For Each xCell In Selection
    If xCell.Value > 0 Then lngBinCount = lngBinCount + 1
Next xCell
 
'create array of Labels
On Error Resume Next 'in case no bins were selected

ReDim ArrayColourBins(lngBinCount, 2)
lngCounter = 1
For Each xCell In Selection
    If xCell.Value > 0 Then 'if the cell has a value
        ArrayColourBins(lngCounter, 1) = xCell.Offset(-1, 0).Value 'put the label into the array
        ArrayColourBins(lngCounter, 2) = xCell.Value 'put the colour value into the array
        xCell.Interior.ColorIndex = ArrayColourBins(lngCounter, 2) 'colour the cell
        lngCounter = lngCounter + 1 'increment the counter
    Else
        xCell.ClearFormats
    End If
Next xCell
Set xCell = Nothing
'dump the array values into cells to prove they were picked up
'test to this point to make sure it works
 '   Range("a4").Select
  '  Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(lngBinCount - 1, 1)).Value = ArrayColourBins

On Error Resume Next 'if these ranges exist, delete them
    ActiveWorkbook.Names.Item("ChromaArray").Delete
    ActiveWorkbook.Names.Item("SeqArray").Delete
    ActiveWorkbook.Names.Item("CurrentRange").Delete

'go to Analysis range
Application.Goto reference:="Analysis"
Application.ScreenUpdating = False
'count range dimensions
    lngRowCount = Selection.Rows.Count - 1 '-1 because of offset
    lngColCount = Selection.Columns.Count
    Set RngStart = ActiveCell 'use RngStart instead of ActiveCell in referencing - its a tiny bit faster
'Create ChromaArray and SeqArray ranges for use in Navigation, format their column widths
Set Sheet = ActiveSheet
    'find the address of what will be the ChromaArray Range
    SRangeAdds = Range(RngStart.Offset(0, lngColCount + 1), RngStart.Offset(lngRowCount, (lngColCount * 2))).Address
    'define the ChromaArray named range
    ActiveWorkbook.Names.Add Name:="ChromaArray", RefersTo:="=" & Sheet.Name & "!" & SRangeAdds
    Range("ChromaArray").Columns.ColumnWidth = 4
    'find the address of what will be the SeqArray Range
    SRangeAdds = Range(RngStart.Offset(0, (lngColCount * 2) + 2), RngStart.Offset(lngRowCount, (lngColCount * 3) + 1)).Address
    'define the SeqArray named range
    ActiveWorkbook.Names.Add Name:="SeqArray", RefersTo:="=" & Sheet.Name & "!" & SRangeAdds
    Range("SeqArray").Columns.ColumnWidth = 4
Set Sheet = Nothing 'release from memory

'set lngCCount for use with column looping
    lngCCount = 1
'loop through columns
For lngCCount = 1 To lngColCount
    Application.StatusBar = "Processing Column " & lngCCount & " of " & lngColCount
    'select the range without selecting
    SRangeAdds = Range(RngStart.Offset(0, lngCCount - 1), RngStart.Offset(lngRowCount, lngCCount - 1)).Address

'create and fill the CurrentArray with the colour labels
    ReDim CurrentArray(lngRowCount, 1)
    CurrentArray = Range(SRangeAdds).Value
' find the min and max value of myRange
' incredibly - its' actually faster to do it this way than using worksheet functions.
    lngCounter = 1
        myMin = CurrentArray(lngCounter, 1)
        myMax = CurrentArray(lngCounter, 1)
    For lngCounter = 2 To lngRowCount + 1 'loop through rows
        If CurrentArray(lngCounter, 1) < myMin Then
            myMin = CurrentArray(lngCounter, 1)
        End If
        If CurrentArray(lngCounter, 1) > myMax Then
            myMax = CurrentArray(lngCounter, 1)
        End If
    Next lngCounter
' create the bin values, based on myMin/myMax and store in the BinArray
    ReDim BinArray(lngBinCount, 1)
    lngCounter = 1
    For lngCounter = 1 To lngBinCount
        BinArray(lngCounter, 1) = (((myMax - myMin) / lngBinCount) * lngCounter) + myMin
        'Debug.Print "(((" & myMax & "-" & myMin & ") / " & lngBinCount & ") * " & lngCounter & ") + " & myMin & "=" & BinArray(lngCounter, 1)
    Next lngCounter
    
    Set myMin = Nothing
    Set myMax = Nothing
    
'use the CurrentArray to calculate/store bin results
    lngCounter = 1 'set the counter
    For lngCounter = 1 To (lngRowCount + 1)
        lngBinCounter = 1 'set the bincounter
        Do While lngBinCounter <= lngBinCount 'while the number of bins counted is less than or equal to the total number of bins
            If CurrentArray(lngCounter, 1) <= BinArray(lngBinCounter, 1) Then Exit Do 'if the value of cell is less than the bin value
            lngBinCounter = lngBinCounter + 1
        Loop
            CurrentArray(lngCounter, 1) = ArrayColourBins(lngBinCounter, 1)
    Next lngCounter
  
  'fill in ChromaArray
  Range(RngStart.Offset(0, lngCCount + lngColCount), RngStart.Offset(lngRowCount, lngCCount + lngColCount)).Value = CurrentArray
  'fill in SeqArray
  Range(RngStart.Offset(0, lngCCount + (lngColCount * 2) + 1), RngStart.Offset(lngRowCount, lngCCount + (lngColCount * 2) + 1)).Value = CurrentArray

Erase CurrentArray ' deletes the variable contents, free some memory
Erase BinArray ' deletes the variable contents, free some memory

Next lngCCount ' next column
    Set RngStart = Nothing 'free a little memory
    
'colour the ChromaArray
    Range("ChromaArray").Select

    varStatBar1 = Selection.Cells.Count
    Application.StatusBar = "Starting CHROMABLAST on " & varStatBar1 & " cells"

'Set the default colour of cells to the first bin
    Range("ChromaArray").Interior.ColorIndex = ArrayColourBins(1, 2)
lngCounter = 2 'set the counter
For lngCounter = 2 To lngBinCount 'loop through each bin
varValue = ArrayColourBins(lngCounter, 1) 'label of bin
varCheckBin = ArrayColourBins(lngCounter, 2) 'colour
    Application.StatusBar = "CHROMABLASTING CELLS - now working on BIN " & lngCounter & " of " & lngBinCount & " with " & varStatBar1 & "cells"

With Selection
        Set rngChroma = .Find(varValue, LookIn:=xlValues) 'within the ChromaArray look for the matching bin label
    If Not rngChroma Is Nothing Then 'It is the same as If rngChroma Is Something Then which unfortunately is not valid code. It is testing if the previous action was successful in creating an object,or whether it failed.
        firstAddress = rngChroma.Address
        Do
            rngChroma.Interior.ColorIndex = varCheckBin 'set the cell colour to the bin
            Set rngChroma = .FindNext(rngChroma)
        Loop While rngChroma.Address <> firstAddress 'Not rngChroma Is Nothing And rngChroma.Address <> firstAddress
    End If
Set rngChroma = Nothing
End With
Set varValue = Nothing
Set varCheckBin = Nothing
Next lngCounter
    
'clear the contents of the cells
    Selection.ClearContents
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic 'turn calculation back on again
    Application.AutoRecover.Enabled = True
    Application.EnableEvents = True
    ActiveWindow.Zoom = True

    Debug.Print Timer - dlStart
End Sub

[agibsonsw]

Hello.
Just a small point, but CurrentArray is an Excel property that returns a range object. It might be worth changing your
variable name to, say currArray, to avoid confusing Excel - Excel might be checking the current selection every time
you refer to your array. I'm not sure if this would impact the speed. Andy.

[WebGenii]

Cool - I didn't know that

-0.2 of a second difference (on my small data set)

[Jan Karel Pieterse]

Two remarks.
1. When defining the range names, make sure you wrap the worksheet name with single quotes so the code does not hiccup of the sheetname happens to contain a space

2. I strongly suspect the mayor time consumption of your code goes into the part where you color the cells based on the bins. Try rewriting that part so it uses autofilter to filter the relevant rows and then color them in one statement using the specialcells object.

[WebGenii]

I have two questions about autofiltering. I assume I'll have to loop through each column and filter each column separately.
1) isn't there a size limit to the number of cells in an autofilter?
2) But doesn't an autofilter require selecting the cells?

the other problem I encounter is when the item I'm filtering by doesn't exist in the column.

[rory]

1. Not that I am aware of. (though there is a limit to the number of items you can manipulate at once using the specialcells(xlcelltypevisible) method.)
2. No! :)

[Jan Karel Pieterse]

If the item filtered by isn't in the table, the specialcells method returns an error, which you can trap.

[rory]

If you check the visible cell count of one column of the autofilter range, if it's 1, then only the header row is visible. :)