A worksheet function applied to all

BMD

Board Regular
Joined
Oct 5, 2005
Messages
211
This is my working function,,,,,, but it only works for Sheet1 and I tryed to copy it to ThisWorkbook but it does not work for any other sheet. Do I realy need to copy it to all sheet and mainten all of them?

Thanks,
This group is excellence,
The Learning, Bruce.

'"Pass" in cell G row A:O Green.
'"Fail" in cell G row A:O Red
'"Pass" in cell G cell M is = "to {Major or Minor}" turn the row A:O Yellow.
Option Compare Text
Public Sub demo()
Letter = "P"
If Letter = "p" Then MsgBox "Case does not matter"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WatchRange As Range
Dim cell As Range
Dim rng As Range

Set WatchRange = Columns("G")
Set WatchRangeM = Columns("M")
Dim myMultiAreaRange As Range
Set myMultiAreaRange = Union(WatchRange, WatchRangeM)

If Intersect(Target, myMultiAreaRange) Is Nothing Then Exit Sub
Set rng = Intersect(Target, myMultiAreaRange)

For Each cell In rng
With Range(Cells(cell.Row, "A"), Cells(cell.Row, "O")).Font
Select Case LCase(cell):
Case "Pass", "P"
If Cells(cell.Row, "M") = "Major" Or Cells(cell.Row, "M") = "Minor" Or Cells(cell.Row, "M") = "Maj" Or Cells(cell.Row, "M") = "Min" Then
.ColorIndex = 33
.Bold = True
Else
.ColorIndex = 10
.Bold = False
End If
Case "Major", "Maj", "Minor", "Min"
If Cells(cell.Row, "G") = "Pass" Or Cells(cell.Row, "G") = "P" Then
.ColorIndex = 33
.Bold = True
Else
.ColorIndex = 10
.Bold = False
End If
Case "Fail", "F"
.ColorIndex = 3
.Bold = False
Case Else
.ColorIndex = 1
.Bold = False
End Select:
End With
Next cell
End Sub
 

a7n9

Well-known Member
Joined
Sep 15, 2004
Messages
696
No, you don't need to copy it to all the worksheets. Just insert a module and copy your macro there.

That's it, you can use this macro from any worksheet and if you want to use it for any workbook copy it into the personal workbook.
 

Joe Was

MrExcel MVP
Joined
Feb 19, 2002
Messages
7,539
In the VBA Editor Toolbar: Insert - Module
Cut and paste your Function to this Module.

Or if you want to work on the entire workbook add another loop to loop through each sheets data. Note looking at your code though you will need to make other changes depensing on how you want it to work or repost data. So I think you just need to do the above!
 

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
Hello, guys,

cut the code in your worksheetmodule
and paste in the workbookmodule

replace this line
Private Sub Worksheet_Change(ByVal Target As Range)
with
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
I didn't test it for your macro, but this is the "general method" to do what (I think) you asked

kind regards,
Erik

EDIT: a tip for BMD: please use the code-button to display code nicely
 

BMD

Board Regular
Joined
Oct 5, 2005
Messages
211
I now have:
VBAProject (book1.xls)
Microsoft Excel Objects
Sheet1 (Sheet1)
Sheet2 (Sheet2)
Sheet3 (Sheet3)
ThisWorkbook
Modules
Module1

when I make a change to sheet two the formatting does not happen. There is nothing code on sheet 1 any more and that sheet is also not working any more.

I could 'Try and try again: "The way of the coder!"'

Thanks,
Bruce.
 

Seti

Well-known Member
Joined
May 19, 2002
Messages
2,916
How about creating a WorksheetChange macro in each sheet that calls a macro in module1 rather than duplicating all this code in each sheet?
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
75,288
Bruce

You need to reference the sheet that has changed in the SheetChange event in the ThisWorkbook module.

Try something like this, untested code.

Note the parameter Sh which is passed to the code. This is the sheet that the change has been made on.
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim WatchRange As Range
Dim WatchRangeM As Range
Dim cell As Range
Dim rng As Range
Dim myMultiAreaRange As Range

Set WatchRange = Sh.Columns("G")
Set WatchRangeM = Sh.Columns("M")

Set myMultiAreaRange = Union(WatchRange, WatchRangeM)

If Intersect(Target, myMultiAreaRange) Is Nothing Then Exit Sub
    
Set rng = Intersect(Target, myMultiAreaRange)

For Each cell In rng

    With Sh.Range(Sh.Cells(cell.Row, "A"), Sh.Cells(cell.Row, "O")).Font
        Select Case LCase(cell):
            Case "Pass", "P"
                Select Case Sh.Cells(cell.Row, "M")
                    Case "Major", "Minor", "Maj", "Min"
                        .ColorIndex = 33
                        .Bold = True
                    Case Else
                        .ColorIndex = 10
                        .Bold = False
                End Select
            Case "Major", "Maj", "Minor", "Min"
                Select Case Sh.Cells(cell.Row, "G")
                    Case "Pass", "P"
                        .ColorIndex = 33
                        .Bold = True
                    Case Else
                        .ColorIndex = 10
                        .Bold = False
                End Select
            Case "Fail", "F"
                .ColorIndex = 3
                .Bold = False
            Case Else
                .ColorIndex = 1
                .Bold = False
        End Select
    End With
Next cell

End Sub
This code should go in the ThisWorkbook module.

To get to that double click on ThisWorkbook under Microsoft Excel Objects in the VBE Project Explorer.
 

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
what do you have in your workbook module now?

perhaps you disabled "enable events"
so run this
Sub foo()
Application.EnableEvents = True
End Sub


seti,
How about creating a WorksheetChange macro in each sheet that calls a macro in module1 rather than duplicating all this code in each sheet?
my post used the excel-inbuilt-solution to get the same worksheetchangeevent for each sheet
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
MsgBox "you changed sheets " & Sh.Name
End Sub
does this work for you ?

kind regards,
Erik
 

BMD

Board Regular
Joined
Oct 5, 2005
Messages
211
This is now my whole module1 code. nothing is listed on any sheet. I now have a VBAProject (Book2) under VBAProject (Book1.xls) and I don't know where it came from.

Code:
'"Pass" in cell G row A:O Green.
'"Fail" in cell G row A:O Red
'"Pass" in cell G cell M is = "to {Major or Minor}" turn the row A:O Blue and bold.
Option Compare Text
Public Sub demo()
Letter = "P"
If Letter = "p" Then MsgBox "Case does not matter"
End Sub
'Private Sub Worksheet_Change(ByVal Target As Range)
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dim WatchRange As Range
Dim cell As Range
Dim rng As Range

Set WatchRange = Columns("G")
Set WatchRangeM = Columns("M")
Dim myMultiAreaRange As Range
Set myMultiAreaRange = Union(WatchRange, WatchRangeM)

If Intersect(Target, myMultiAreaRange) Is Nothing Then Exit Sub
Set rng = Intersect(Target, myMultiAreaRange)

For Each cell In rng
    With Range(Cells(cell.Row, "A"), Cells(cell.Row, "O")).Font
        Select Case LCase(cell):
        Case "Pass", "P"
            If Cells(cell.Row, "M") = "Major" Or Cells(cell.Row, "M") = "Minor" Or Cells(cell.Row, "M") = "Maj" Or Cells(cell.Row, "M") = "Min" Then
            .ColorIndex = 33
            .Bold = True
            Else
            .ColorIndex = 10
            .Bold = False
            End If
        Case "Major", "Maj", "Minor", "Min"
            If Cells(cell.Row, "G") = "Pass" Or Cells(cell.Row, "G") = "P" Then
            .ColorIndex = 33
            .Bold = True
            Else
            .ColorIndex = 10
            .Bold = False
            End If
        Case "Fail", "F"
            .ColorIndex = 3
            .Bold = False
        Case Else
            .ColorIndex = 1
            .Bold = False
        End Select:
    End With
Next cell
End Sub

Sub foo()
Application.EnableEvents = True
End Sub
Bruce.
 

Forum statistics

Threads
1,078,428
Messages
5,340,186
Members
399,359
Latest member
trprpfo

Some videos you may like

This Week's Hot Topics

  • Problem with Radio Button's format control
    I am creating an employee evaluation template (a sample is below) Column A is the category Column B, C D, E and F will be ratings (unacceptable...
  • Last Display on userform to a Listbox
    [CODE=vba] lstdisplay.ColumnCount = 15 lstdisplay.RowSource = "A1:O600000" [/CODE] So when i do this it Displays everything on the sheet i am...
  • Rename and move files to a new location
    Dear all, I have an excel file with the following information. The actual file name is at column A but i want to rename it using the following...
  • Help with True/False Formula
    Hello! Am stumped how to fix this formula, in which my result returns 'True', but it should return False. =IF(AG2=True...
  • Clear extra characters from a provided range of cells
    Dear All, I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when...
  • Help with Current and highest streaks
    Hi there, I've just joined the forum and this is my first post. I've already spent quite a bit of time searching the net and this forum for a...
Top