ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Creating Color Row "Control Panel" (https://www.excelbanter.com/excel-programming/364968-re-creating-color-row-control-panel.html)

stevec

Creating Color Row "Control Panel"
 
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

Creating Color Row "Control Panel"
 
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

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



All times are GMT +1. The time now is 08:46 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com