Creating Color Row "Control Panel"

[SteveC]

In worksheet "AllCos", ColumnB, I have a list of names,

In worksheet "HList", A13:Z3000 I have data I want to color format by row.

ColB in "HList" contains names listed in ColB "AllCos".

I would like a macro to copy the formatting in ColB "AllCos", and apply it
to the rows of "HList" by matching the values in ColB AllCos to ColB HList.

For example:

Sheet "AllCos"
ColB
Pears the background color of this cell is yellow
Apples the background color of this cell is blue
Bannanas the background color of this cell is green


Sheet "HList"
ColB
Apples This row A:AS is colored blue, because it is applying format from
"AllCos"
Apples This row A:AS is colored blue, as above
Pears This row A:AS is colored yellow
etc...

separately,
This may or may not be relevant: thanks to Jim Cone and Patrick Malloy, I
have a macro now that applies row color formatting according to preset
definitions. However, now I'd like to have flexibility in modifynig the
color formats as I explained above. I've reposted it below. I hope it's
relevant.

Even better:
the macro above -- it woudl be great if it would apply all formatting found
in ColB Allcos to the rows in HList, not just color -- that would be super.

Thanks for your help.

Type Colors
green As Long
yellow As Long
blue As Long
White As Long
End Type

Sub Update_Report_Colors()
Dim sheet As Worksheet
Dim i As Integer
Dim keycol As Long
Dim cell As Range
Dim found As Range
Dim MyColor As Colors
Dim color As Long

Set sheet = Worksheets("HotList")

MyColor.green = 35
MyColor.yellow = 36
MyColor.blue = 34
MyColor.White = 2
keycol = 2

With sheet
Set found = .Columns(keycol). SpecialCells(xlCellTypeConstants, xlTextValues)

For Each cell In found
Select Case cell.Value

Case "Advertising"
color = MyColor.green

Case "Apparel Retail"
color = MyColor.yellow

Case "Apparel, Accessories and Luxury Goods"
color = MyColor.blue

Case "Auto Components"
color = MyColor.green

Case "Auto Parts and Equipment"
color = MyColor.yellow

Case "Automobile Manufacturers"
color = MyColor.blue

Case "Automobiles"
color = MyColor.green

Case "Automobiles and Components"
color = MyColor.yellow

Case "Automotive Retail"
color = MyColor.blue

Case "Broadcasting and Cable TV"
color = MyColor.green

'About 200 more cases and then...

Case Else
color = MyColor.White
End Select

With .Range(.Cells(cell.Row, "A"), .Cells(cell.Row, "Z"))
.Interior.ColorIndex = color
End With
Next
End With
End Sub

 

[SteveC]

Maybe this is a better example of what I'm looking for:

For example:
Step 1) In sheet "AllCos", format cell B19 background color blue.

Step 2) In sheet "HList," press a button that will run a macro that will
apply color blue to all cells in a row (A:AS) where the value in sheet
"HList" Column B matches the value of Cell B19 in sheet "Allcos.

Applying formatting to sheet HList from sheet AllCos should work not only
for Cell B19 in AllCos, but for any cells in Col B All Cos...

thanks again...

this macro should match and apply any formatting.

 

[SteveC]

Here is a macro from Ron de Bruin that loops through Column B of Sheet1,
matches and deletes rows in the active sheet.

The key component I don't know how to change is this: Then .Rows(Lrow).Delete

How do I change that to Copy the format in the matching cell in ColB of
Sheet1, and apply it to the row A:AS in the active sheet, which I'm naming
sheet 2?

Sub Example3()
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim StartRow As Long
Dim EndRow As Long

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

ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView

With ActiveSheet
..DisplayPageBreaks = False
StartRow = 1
EndRow = .Cells(.Rows.Count, "B").End(xlUp).Row

For Lrow = EndRow To StartRow Step -1

If IsError(.Cells(Lrow, "B").Value) Then
'Do nothing, This avoid a error if there is a error in the cell

ElseIf Not IsError(Application.Match(.Cells(Lrow, "B").Value, _
Sheets("Sheet1").Range("b4:b100"), 0)) Then .Rows(Lrow).Delete

End If
Next
End With

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

End Sub

 

[SteveC]

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