View Single Post
  #3   Report Post  
Posted to microsoft.public.excel.programming
stevec stevec is offline
external usenet poster
 
Posts: 177
Default Creating Color Row "Control Panel"

Here is a solution I received. Hope this helps anyone with a similar
interest... Only problem with this... it takes about a long time to for the
macro to apply itself... paste all this code in a module and run the maacro:
Sub Format_Matching_NoCalcNoView()

Sub Apply_Match(WS As Worksheet, TX As String, CL As Long, FON As Font)
Dim i As Integer
Dim j As Integer
Dim r As Range
Dim strrange As String
Dim rrow As Range
WS.Select
Set r = Range("B13:B65535")
i = r.Row
j = r.Column


While WS.Cells(i, j).Formula < ""
If Trim(UCase(WS.Cells(i, j).Text)) = Trim(UCase(TX)) Then
strrange = "A" & Trim(CStr(i)) & ":AS" & Trim(CStr(i))
Set rrow = Range(strrange)
rrow.Select
With rrow.Cells.Font
.Bold = FON.Bold
.Italic = FON.Italic
.Name = FON.Name
.color = FON.color
.Underline = FON.Underline
.Size = FON.Size
End With
Selection.Interior.ColorIndex = CL
End If
i = i + 1
Wend


End Sub

Sub Format_Matching_Entries()
Dim i As Integer
Dim j As Integer
Dim r As Range
Dim rcell As Range
Dim strrange As String
Dim COL As Long
Dim TXT As String
Dim WSH As Worksheet
Dim FNTL As Font
Sheets("ControlPanel").Select
Set r = Range("B4:B65535")
i = r.Row
j = r.Column
While ThisWorkbook.Sheets("ControlPanel").Cells(i, j).Formula < ""
Sheets("ControlPanel").Select
strrange = "B" & Trim(CStr(i)) & ":B" & Trim(CStr(i))
Set rcell = Range(strrange)
rcell.Select
If Selection.Interior.ColorIndex < xlNone Or _
Selection.Font.Bold = True Or _
Selection.Font.Italic = True Or _
Selection.Font.Name < "Arial" Or _
Selection.Font.ColorIndex < xlAutomatic Or _
Selection.Font.Underline = xlUnderlineStyleSingle Or _
Selection.Font.Size < 10 Then
Set WSH = ThisWorkbook.Sheets("Sheet1")
TXT = ThisWorkbook.Sheets("ControlPanel").Cells(i, j).Text
COL =
ThisWorkbook.Sheets("ControlPanel").Range(strrange ).Interior.ColorIndex
Set FNTL =
ThisWorkbook.Sheets("ControlPanel").Range(strrange ).Font
Call Apply_Match(WSH, TXT, COL, FNTL)
End If
i = i + 1
Wend
Sheets("Sheet1").Select
Range("A13").Select
End Sub


Sub Format_Matching_NoCalcNoView()

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView

Application.Run "Format_Matching_Entries"


ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With