Interior.ColorIndex - Paste instead of loop speed up of macro possible

[Vinci2504]

Hi All,

I am trying to find method to speed up below macro.
Do you think is possible to paste .Interior.ColorIndex to sheet from Array instead of loop ?
Code like below.

Sub test012502()

Dim colorArr As Variant
Dim DataSheet As Worksheet
Dim SheetName As String
SheetName = ActiveWorkbook.ActiveSheet.Name
Set DataSheet = ThisWorkbook.Worksheets(SheetName)

Dim maxRows As Double: maxRows = 3000
Dim maxCol As Double: maxCol = 24
Dim numCells As Double: numCells = maxRows * maxCol

Call TurnOffStuff
ReDim colorArr(1 To maxCol, 1 To maxRows)

DataSheet.Cells.Interior.ColorIndex = xlNone
DataSheet.Cells.Clear

Dim StartTime As Double:  StartTime = Timer
    With DataSheet
        For col = LBound(colorArr, 1) To UBound(colorArr, 1)
            For Row = LBound(colorArr, 2) To UBound(colorArr, 2)
                .Cells(Row, col).Value = Round(Rnd * 10, 0)
                colorArr(col, Row) = .Cells(Row, col)
            Next Row
        Next col
    End With

    With DataSheet
        ' is possible to paste .Interior.ColorIndex to sheet from Array instead of loop ?
        .Range(.Cells(1, maxCol + 1), .Cells(UBound(colorArr, 2), 2 * maxCol)) = Application.Transpose(colorArr)
        
        ' col by col, row by row is so slowly
        For col = maxCol + 1 To 2 * maxCol
            For Row = LBound(colorArr, 2) To UBound(colorArr, 2)
                .Cells(Row, col).Interior.ColorIndex = colorArr(col - maxCol, Row)
            Next Row
        Next col
    End With

Call TurnOnStuff
'MsgBox "Done: " & Round(Timer - StartTime, 5) & "s", vbInformation, "Done"
Debug.Print "Done " & Round(Timer - StartTime, 3) & "second" & " - " & numCells & "cells"

End Sub

Public Function TurnOffStuff()
    With Application
     .Calculation = xlCalculationManual
     .ScreenUpdating = False
     .EnableEvents = False
     .DisplayAlerts = False
    End With
End Function

Public Function TurnOnStuff()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .CalculateBeforeSave = True
    End With
End Function

 

[Peter_SSs]

First some comments.

1. I'm not sure if there is a reason why you structure your array with columns and rows transposed but then later transpose that array to the normal orientation. I have skipped that.
2. Also not sure if there is a reason that you have duplicated the array values in the worksheet. I have just entered them once.
3. It is not a good idea to use a variable name that is already a special word in vba (eg "row") so I have changed that.

Anyway, you could give this a go. For me the timing was about 1.5 seconds instead of your code at about 3.5 seconds.

Sub test012502_v2()
  Dim rw As Long, col As Long, clr As Long
  Dim colorArr As Variant
  Dim DataSheet As Worksheet
  Dim SheetName As String
  Dim maxRows As Double: maxRows = 3000
  Dim maxCol As Double: maxCol = 24
  Dim numCells As Double: numCells = maxRows * maxCol
  
  SheetName = ActiveWorkbook.ActiveSheet.Name
  Set DataSheet = ThisWorkbook.Worksheets(SheetName)
  Call TurnOffStuff
  ReDim colorArr(1 To maxRows, 1 To maxCol)
  
  DataSheet.Cells.Interior.ColorIndex = xlNone
  DataSheet.Cells.Clear
  
  Dim StartTime As Double:  StartTime = Timer
      With DataSheet
          For rw = 1 To maxRows
              For col = 1 To maxCol
                  colorArr(rw, col) = Round(Rnd * 10, 0)
              Next col
          Next rw
      End With
      Application.FindFormat.Clear
      With DataSheet
          With .Cells(1, maxCol + 1).Resize(maxRows, maxCol)
            .Value = colorArr
            For clr = 0 To 9
              Application.ReplaceFormat.Interior.ColorIndex = clr
              .Replace What:=clr, Replacement:=clr, LookAt:=xlWhole, SearchFormat:=False, ReplaceFormat:=True
            Next clr
          End With
      End With
      Application.ReplaceFormat.Clear
  Call TurnOnStuff
  Debug.Print "Done " & Round(Timer - StartTime, 3) & "second" & " - " & numCells & "cells"
End Sub

 

[jasonb75]

Not related to the question, but one observation with the code.

  SheetName = ActiveWorkbook.ActiveSheet.Name
  Set DataSheet = ThisWorkbook.Worksheets(SheetName)

ActiveWorkbook and ThisWorkbook are not necessarily the same. If the code module is in Book1 and you run it with Book2 active, then you could encounter problems. Of course, if the intention is to run the code on a sheet with the same name but in a different workbook, then what you have is perfect for the task (as long as sheets with identical names appear in both workbooks).

If that's not the intention, then I would suggest using something like

Set DataSheet = ThisWorkbook.ActiveSheet

eliminating the need for the SheetName String variable.

 

[Vinci2504]

Hi Guys,

Thank you both for your feedback.

Peter, your code really made my week! I still need to learn so much. Thanks

 With .Cells(1, maxCol + 1).Resize(maxRows, maxCol)
            .Value = colorArr

Regarding point 1: I have always transposed Array into a sheet. Thanks
Point 2: Only for present data for easy to find some information. In final code it is not required.
Point 3: You right. I always used 'row'. I rarely use .row it in my code. But I know what you mean and from now 'row' will be not used as variant.



In general the result what I want to receive you can see in below code with your cues.
Right now I am thinking if is any way to speed up '.AddComment'. Do you think that any other method can be selected to receive similar result?

Sub test012502_v2()
  Dim rw As Long, col As Long, i As Long
  Dim colorArr As Variant
  Dim informationArr As Integer
  Dim DataSheet As Worksheet
  Dim SheetName As String
  Dim maxRows As Double: maxRows = 1000
  Dim maxCol As Double: maxCol = 24
  Dim numCells As Double: numCells = maxRows * maxCol
  
  Set DataSheet = ThisWorkbook.ActiveSheet
  Call TurnOffStuff
  ReDim colorArr(1 To maxRows, 1 To maxCol)
  ReDim arrInformation(1 To maxCol)
  
'0 as default for arr
  For i = 1 To maxCol
    arrInformation(i) = 0
  Next i
  
  DataSheet.Cells.Interior.ColorIndex = xlNone
  DataSheet.Cells.Clear
  
  Dim StartTime As Double:  StartTime = Timer
      With DataSheet
          For rw = 1 To maxRows
              For col = 1 To maxCol
                  colorArr(rw, col) = Round(Rnd * 10, 0)
              Next col
          Next rw
      End With
     ' Application.FindFormat.Clear
      With DataSheet
          With .Cells(3, 1).Resize(maxRows, maxCol)
            .Value = colorArr
          End With
          
'if Cells(row,col) value = 3, then Cell.Interior.ColorIndex = 3
          With .Cells(3, 1).Resize(maxRows, maxCol)
            For rw = 1 To maxRows
                For col = 1 To maxCol
                    If colorArr(rw, col) = 3 Then
                        arrInformation(col) = arrInformation(col) + 1
                        .Cells(rw, col).Interior.ColorIndex = 3
                        .Cells(rw, col).AddComment "Data Wrong"
                    End If
                Next col
             Next rw
          End With
          
'Calculate how many data do not fulfill requirement and add information to each cell
          With .Cells(1, 1).Resize(1, maxCol)
            .Value = arrInformation
             For col = 1 To maxCol
                If arrInformation(col) = 0 Then
                    .Cells(1, col).Interior.ColorIndex = 4
                    .Cells(1, col).AddComment "Data OK"
                End If
             Next col
          End With
      End With

    
  Call TurnOnStuff
  Debug.Print "Done " & Round(Timer - StartTime, 3) & "second" & " - " & numCells & "cells"
End Sub

Function TurnOffStuff()
    With Application
     .Calculation = xlCalculationManual
     .ScreenUpdating = False
     .EnableEvents = False
     .DisplayAlerts = False
    End With
End Function

Function TurnOnStuff()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .CalculateBeforeSave = True
    End With
End Function

 

[Peter_SSs]

Right now I am thinking if is any way to speed up '.AddComment'. Do you think that any other method can be selected to receive similar result?

Not sure why you think you need to speed up thr .AddComment? Your whole code completes in less than a quarter of a second for me for the 24,000 cells.
I did try a couple of alternative methods but they were slower than your existing code.