Solved

Copying the format of 1 of 6 different cells to 80,808 cells.

Posted on 2011-03-17
14
414 Views
Last Modified: 2012-05-11
Hi.

I'm building a grid which needs to have the cell formatted based upon the value.

Sheet 1 contains a grid of Service Providers (in Column A) and Customers (in Row 1).

The values indicate the level of the relationship between the customer and the service provider.

Example of top left corner of sheet
The formatting is based upon another sheet which contains the priority level and the level is formatted as you see in the image above.

I'm using VBA to read the priorities and to format the cells.

Initially, I was using the PasteSpecial(xlFormat) mechanism, but it was horrendously slow for 80,808 cells.

I tried just copying the bold, color and interior color, and that was still quite slow.

So.

My idea is can I do the following.

1 - Iterate the priority levels on the second sheet.
2 - Select all cells in the first sheet with the same level (0 and blank are to be treated the same).
3 - Apply the format of the cell in the second sheet to all the cells in the first sheet.

In my mind this should be REALLY quick to run as there are only 7 different levels.

But I don't know how to select all cells with a specific value.

Any ideas?

I've included the small sample with the second sheet here : Formatting.xls

I can't use conditional formatting as that only has 3 levels and I'm using Excel 2003.

Richard.
0
Comment
Question by:RQuadling
  • 4
  • 4
  • 3
  • +2
14 Comments
 
LVL 12

Assisted Solution

by:telyni19
telyni19 earned 100 total points
ID: 35159633
Here's how I would do it, using named ranges for the cells to pull formatting from, and arrays to hold the formatting information. I tested it on a column of nearly 10,000 items and it only took a few seconds, so I would think that on your full set of 80,000 cells it should still only take maybe 30 seconds or less.
Sub ColorCopyTest()
Dim i As Integer
Dim colFont() As Long
Dim colBack() As Long
Dim rngColor As Range

On Error GoTo ErrSkip

Application.ScreenUpdating = False
Const intLevels As Integer = 6 'max value

ReDim colFont(intLevels)
ReDim colBack(intLevels)

'Have the formatted cells named "Level0", "Level1" and so on
For i = 0 To intLevels
colFont(i) = Sheets("Sheet2").Range("Level" & i).Font.Color
colBack(i) = Sheets("Sheet2").Range("Level" & i).Interior.Color
Next i

Set rngColor = Range("B2:O18")
For i = 1 To rngColor.Cells.Count
    If rngColor(i).Value > 0 And rngColor(i).Value < intLevels + 1 Then
        rngColor(i).Font.Color = colFont(rngColor(i).Value)
        rngColor(i).Interior.Color = colBack(rngColor(i).Value)
    Else
        rngColor(i).Font.Color = colFont(0)
        rngColor(i).Interior.Color = colBack(0)
    End If
Next i

ExitErr:
Set rngColor = Nothing
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub

ErrSkip:
MsgBox Err.Number & ": " & Err.Description
Resume ExitErr
End Sub

Open in new window

Formatting-Coded.xls
0
 
LVL 59

Assisted Solution

by:Chris Bottomley
Chris Bottomley earned 200 total points
ID: 35160176
The following is executed from setColours

It finds each set of matching values using an array and sets all the relevant cells at the same time.  It cycles through the values 1 to 6 and is hopefully self explanatory

Chris
Sub setColours()
Dim vals As Variant
Dim rng As Range
Dim celRef As Range
Dim workingRange As Range

    Sheets(1).Select
    Set workingRange = ActiveSheet.Range(ActiveSheet.Range("b2").Address & ":" & ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Address)
    workingRange.Font.Color = 0
    workingRange.Interior.Color = 16777215
    workingRange.Font.Bold = False
    
    For vals = 1 To 6
        Set celRef = Sheets(2).Cells.Find(what:=vals)
        On Error Resume Next
        Set rng = findCells(workingRange, CStr(vals))
        On Error GoTo 0
        If rng Is Nothing Then Exit Sub
        With rng
            .Font.Color = celRef.Font.Color
            .Interior.Color = celRef.Interior.Color
            .Font.Bold = celRef.Font.Bold
        End With
    Next
    
End Sub

Function findCells(rng As Range, strValue As String) As Range
Dim rngCell As Range
Dim strFirstCell As String
Dim rngGenerator As Range

    Set rngCell = rng.Find(what:=strValue, after:=rng.Cells(rng.Cells.Count))
    
    If Not rngCell Is Nothing Then
        strFirstCell = rngCell.Address
        Set rngGenerator = rngCell
    End If
    Do Until rngCell Is Nothing
        Set rngCell = rng.FindNext(after:=rngCell)
        If rngCell.Address = strFirstCell Then
            Exit Do
        End If
        Set rngGenerator = Union(rngGenerator, rngCell)
    Loop
    Set findCells = rngGenerator

End Function

Open in new window

0
 
LVL 18

Assisted Solution

by:krishnakrkc
krishnakrkc earned 200 total points
ID: 35163992
Hi,

Try this one.


Kris
Sub kTest()
    Dim r As Range, f(1 To 7) As String, ka, x
    Dim i As Long, n As Long, lr As Long, dic As Object, j As Long
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    Debug.Print Now
    
    With Sheets("Sheet2")
        Set r = .Range("a2:a8")
        For i = 1 To r.Rows.Count
            With r.Cells(i, 1)
                dic.Item(.Value2) = .Interior.Color
                dic.Item(.Value2) = dic.Item(.Value2) & "|" & .Font.Color
                dic.Item(.Value2) = dic.Item(.Value2) & "|" & .Font.Bold
            End With
        Next
    End With
    
    With Sheets("Sheet1")
        lr = .Range("a" & .Rows.Count).End(xlUp).Row
        With .Range("b2:o" & lr)
            .Interior.Color = 16777215
            .Font.Color = 0
            .Font.Bold = 0
            ka = .Value2
        
            For i = 1 To UBound(ka, 1)
                For j = 1 To UBound(ka, 2)
                    If Len(ka(i, j)) Then
                        If dic.exists(ka(i, j)) Then
                            f(ka(i, j) + 1) = f(ka(i, j) + 1) & "," & Cells(i, j).Address(0, 0)
                            If Len(f(ka(i, j) + 1)) > 245 Then
                                x = Split(dic.Item(ka(i, j)), "|")
                                With .Range(CStr(Mid$(f(ka(i, j) + 1), 2)))
                                    .Interior.Color = CLng(x(0))
                                    .Font.Color = CLng(x(1))
                                    .Font.Bold = CBool(x(2))
                                End With
                                f(ka(i, j) + 1) = ""
                            End If
                        End If
                    Else
                        f(1) = f(1) & "," & Cells(i, j).Address(0, 0)
                        If Len(f(1)) > 245 Then
                            x = Split(dic.Item(0), "|")
                            With .Range(CStr(Mid$(f(1), 2)))
                                .Interior.Color = CLng(x(0))
                                .Font.Color = CLng(x(1))
                                .Font.Bold = CBool(x(2))
                            End With
                            f(1) = ""
                        End If
                    End If
                Next
            Next
            For i = 1 To 7
                If Len(f(i)) > 1 Then
                    x = Split(dic.Item(i - 1), "|")
                    With .Range(CStr(Mid$(f(i), 2)))
                        .Interior.Color = CLng(x(0))
                        .Font.Color = CLng(x(1))
                        .Font.Bold = CBool(x(2))
                    End With
                    f(i) = ""
                End If
            Next
        End With
    End With
    Debug.Print Now
End Sub

Open in new window

0
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 35164040
Kris, can you also tell us how your code differs from the two proposed solutions?
0
 
LVL 59

Assisted Solution

by:Chris Bottomley
Chris Bottomley earned 200 total points
ID: 35164116
Out of interest and accuracy I looked at the second sheet and saw 0 as do not use so skipped it ... the loop should (I see) consider 0 for processing so a simple edit to accomodate that  and be a correct rendition of the request is as follows:

Chris
Sub setColours()
Dim vals As Variant
Dim rng As Range
Dim celRef As Range
Dim workingRange As Range

    Sheets(1).Select
    Set workingRange = ActiveSheet.Range(ActiveSheet.Range("b2").Address & ":" & ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Address)
    workingRange.Font.Color = 0
    workingRange.Interior.Color = 16777215
    workingRange.Font.Bold = False
    
    For vals = 0 To 6
        Set celRef = Sheets(2).Cells.Find(what:=vals)
        On Error Resume Next
        Set rng = findCells(workingRange, CStr(vals))
        On Error GoTo 0
        If rng Is Nothing Then Exit Sub
        With rng
            .Font.Color = celRef.Font.Color
            .Interior.Color = celRef.Interior.Color
            .Font.Bold = celRef.Font.Bold
        End With
    Next
    
End Sub

Function findCells(rng As Range, strValue As String) As Range
Dim rngCell As Range
Dim strFirstCell As String
Dim rngGenerator As Range

    Set rngCell = rng.Find(what:=strValue, after:=rng.Cells(rng.Cells.Count))
    
    If Not rngCell Is Nothing Then
        strFirstCell = rngCell.Address
        Set rngGenerator = rngCell
    End If
    Do Until rngCell Is Nothing
        Set rngCell = rng.FindNext(after:=rngCell)
        If rngCell.Address = strFirstCell Then
            Exit Do
        End If
        Set rngGenerator = Union(rngGenerator, rngCell)
    Loop
    Set findCells = rngGenerator

End Function

Open in new window

0
 
LVL 40

Author Comment

by:RQuadling
ID: 35164160
Hi.

I think iterating the cells is a no-no. Currently, just the population of the cells from a sparse pivot table (i.e. the table does not include all the customers or the service providers), takes 36 seconds (once I've got the formatting done, I'll be working on this).

My current code is looking up the format for each cell and that takes 85 seconds. Very inefficient, but certainly should be able to be improved upon.

So, holding the formats in an array seems like the way to go.

It seems I need to hold 2 objects per priority, .Font and .Interior. I'm not using the borders.

Thanks to chris_bottomley, I can now see how to select all the cells in the grid with a specific value.

And in looking at the UI for the Replace facility, there is the ability to replace the format.

I recorded the macro replacing all of the cells (didn't know I could do replace all for a format ... still learning something new every day!).

The macro is :
Option Explicit

Sub Macro2()
'
' Macro2 Macro
' Macro recorded 2011-03-17 by Richard Alan Quadling
'

'
    Sheets("Sheet2").Select
    Range("A4").Select
    Application.ReplaceFormat.Clear
    Application.ReplaceFormat.NumberFormat = "General"
    With Application.ReplaceFormat
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
    End With
    With Application.ReplaceFormat.Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .ColorIndex = 4
    End With
    Application.ReplaceFormat.Borders(xlLeft).LineStyle = xlNone
    Application.ReplaceFormat.Borders(xlRight).LineStyle = xlNone
    Application.ReplaceFormat.Borders(xlTop).LineStyle = xlNone
    Application.ReplaceFormat.Borders(xlBottom).LineStyle = xlNone
    Application.ReplaceFormat.Borders(xlDiagonalDown).LineStyle = xlNone
    Application.ReplaceFormat.Borders(xlDiagonalUp).LineStyle = xlNone
    With Application.ReplaceFormat.Interior
        .ColorIndex = 50
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    Application.ReplaceFormat.Locked = False
    Application.ReplaceFormat.FormulaHidden = False
    Sheets("Sheet1").Select
    Cells.Replace What:="2", Replacement:="2", LookAt:=xlWhole, SearchOrder _
        :=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=True
End Sub

Open in new window


As you can see the .Rreplace method supports a ReplaceFormat option.

I realised that I could record that macro for each of the priority levels and it would be complete, but I'm not in charge of the data and it is liable to change by the users.

0
 
LVL 40

Author Comment

by:RQuadling
ID: 35164231
A blank entry in the main grid means no decision has been made, so treat this as if this is a DNU (do not use).

A 0 means the decision has been made and it is a DNU.


There may be changes to the priorities. Personally, I've never liked sequential numbering like this as introducing a new level normally means a massive amount of work resetting all the values.

I stick with numbers, but use the numeric columns as sort of flags ...

0000 = Do not use
01nn = Dedicated
02nn = Emergency
03nn = Fallback

That way there is significant opportunity to add in additional levels and still keep the numeric sorting.

Also, there may need to be 2 sheets, one for the working day and one for out of hours.

But as it stands the values are sequential.
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35164268
Richard

What do you still need in this respect if anything?

Chris
0
 
LVL 40

Author Comment

by:RQuadling
ID: 35164323
I think you've given me the next steps.

Iterating the grid is pretty much a no no as that means formatting each cell individually. Something which I know is already slow.

I've got another question coming on trying to get the data from the pivot table into the working grid in something faster than 36 seconds.

But getting the formatting done now.
0
 
LVL 18

Expert Comment

by:krishnakrkc
ID: 35164324
@ssaqibh:

I used 7 arrays to store the cell addresses of each element. Once the len of each array reaches just over 245 I format the range (It error out if the len > 255). It took 9 secs to format over 70000 cells as compared to telyni19's 25 secs.

Kris
0
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 35164478
Thanks, Kris. It helps to know otherwise if the first solution works one might not attempt the other solutions.

Saqib
0
 
LVL 18

Assisted Solution

by:krishnakrkc
krishnakrkc earned 200 total points
ID: 35170148
Hi,

Here is another way...



Kris
Sub kTest()
    Dim r As Range, i As Long, Rng As Range
    
    Debug.Print Now
    
    Set r = Sheet2.Range("a2:a8")
    Set Rng = Sheet1.Range("b2:o" & Sheet1.Range("a" & Rows.Count).End(xlUp).Row)
    
    Const ReplaceStr    As String = "zzzzzzzzz"
    
    With Rng
        .Interior.Color = 16777215
        .Font.Color = 0
        .Font.Bold = 0
    End With
    On Error Resume Next
    With Rng.SpecialCells(4).Cells
        .Interior.Color = r.Cells(1, 1).Interior.Color
        .Value = ReplaceStr
    End With
    For i = 1 To r.Rows.Count
        With Rng
            .Replace r.Cells(i, 1), "", 1
            On Error Resume Next
            With .SpecialCells(4).Cells
                .Interior.Color = r.Cells(i, 1).Interior.Color
                .Font.Color = r.Cells(i, 1).Font.Color
                .Font.Bold = r.Cells(i, 1).Font.Bold
                .Value = r.Cells(i, 1)
            End With
        End With
    Next
    Rng.Replace ReplaceStr, "", 1
    Debug.Print Now
End Sub

Open in new window

0
 
LVL 40

Accepted Solution

by:
RQuadling earned 0 total points
ID: 35180093
Thank you for your comments.

Here is the current working code:
        ' Apply formatting.
        ActiveSheet.Range("C5").Select
        For i_Priority = 0 To i_Priorities
            
            ' Allow blanks to be treated as 0.
            If i_Priority = 0 Then
                i_PriorityRow = 1
            Else
                i_PriorityRow = i_Priority
            End If
            
            ' Short circuit the font and the interior.
            With rng_PriorityDescriptions.Range("B" & 1 + i_PriorityRow)
                Set o_PriorityFont = .Font
                Set o_PriorityInterior = .Interior
                
                ' Build the replacement format.
                With Application.ReplaceFormat
                    .Clear
                    .NumberFormat = "0"
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .Locked = False
                    .FormulaHidden = False
                    With .Font
                        .Name = o_PriorityFont.Name
                        .FontStyle = o_PriorityFont.FontStyle
                        .Size = o_PriorityFont.Size
                        .Strikethrough = o_PriorityFont.Strikethrough
                        .Superscript = o_PriorityFont.Superscript
                        .Subscript = o_PriorityFont.Subscript
                        .Color = o_PriorityFont.Color
                    End With
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    .Borders(xlEdgeBottom).LineStyle = xlNone
                    .Borders(xlEdgeLeft).LineStyle = xlNone
                    .Borders(xlEdgeRight).LineStyle = xlNone
                    .Borders(xlEdgeTop).LineStyle = xlNone
                    With .Interior
                        .Color = o_PriorityInterior.Color
                        .Pattern = o_PriorityInterior.Pattern
                        .PatternColor = o_PriorityInterior.PatternColor
                    End With
                End With
            
                ' Search and replace value accounting for non assigned values.
                If i_Priority = 0 Then
                    s_PriorityValue = ""
                Else
                    s_PriorityValue = .Value
                End If
                
                ' Replace the format of for cells matching the priority.
                ActiveSheet.Cells.Replace _
                    What:=s_PriorityValue, _
                    Replacement:=s_PriorityValue, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    MatchCase:=True, _
                    SearchFormat:=False, _
                    ReplaceFormat:=True
            End With
        Next i_Priority
 

Open in new window


This takes less than a second to run.

[EDITED] Even working code can be wrong. The code above REALLY seems to be working now!
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35180215
THat's a clever improvement, and a nice turn of speed obviously! Nothing more we can do then I guess?

Chris
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
The viewer will learn how to  create a slide that will launch other presentations in Microsoft PowerPoint. In the finished slide, each item launches a new PowerPoint presentation and when each is finished it automatically comes back to this slide: …
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now