Update format of cells to reflect change (1 Viewer)

[Tanya]

Hi
I have a spreadsheet and need to archive the records on several worksheets without removing them. To do this I would like to format the text on each record to strikethrough. I have written this code but it isn't working right:

Sub Archive_Calculate()
Dim r As Range, cell As Range
On Error GoTo ErrHandler
'Look up range C5:C44
Set r = Me.Range("C5:C44")
Application.ScreenUpdating = False
Application.EnableEvents = False

'Wherever the Letter A occurs, select entire row
'and format Font as Strikethrough
For Each cell In r
If cell.Value = "A" Then
cell.EntireRow.Select
.Font.Strikethrough
End If
End With
ErrHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

I then need to update 5 other sheets; Sheet names are Grades, Term1, Term2, Term3, Term4

Any suggestions appreciated as I am very new at vba.

Tanya

 

[Brianwarnock]

If cell.Value = "A" Then
cell.EntireRow.Font.Strikethrough = True
End If


Oh and remove the me. from range

Set r = Range("C5:C44")

I don't like to use cell as a variant as it is too close to CELLS, a keyword ,and can confuse debugging, also lead to typo errors, I would just use c.



Brian

 

[Tanya]

Thank you Brian,
It worked perfectly.

 

[Brianwarnock]

Thanks for coming back, its amazing how rare that is on the Ecxel forum.
BTW if you want to do all of the sheets in one go and the tange is the same you could loop through the sheet names stored in an array

Dim myarray As Variant
myarray = Array("sheet1", "sheet2", "sheet3")
Dim n As Integer

n=0
Do While n < 3
Set r = Sheets(myarray(n)).Range("C5:C44")
Application.ScreenUpdating = False
Application.EnableEvents = False

'Wherever the Letter A occurs, select entire row
'and format Font as Strikethrough
For Each cell In r
If cell.Value = "A" Then
cell.EntireRow.Font.Strikethrough = True
End If
Next
n = n + 1
Loop

approach, obviously altering code as necessary for your situation.
Just a thought.

Brian

 

[Tanya]

Hi Brian
I really appreciate your support with this project.
I'm struggling though with getting the code to run when text is changed and have attached a copy of my project for your consideration. The main sheet is Grades and Term 1, Term 2 etc get updated information from this main sheet.
Perhaps I have used a wrong expression? I placed the code you gave me in Module1 and if I run it from within VBA it works perfectly.
Thank you in advance.
Kind regards
Tanya

 

[Brianwarnock]

Hi

There was an error in my air code, as N starts at 0 then the Do While n < 3 not 4, presumably it did not cause an error or maybe you corrected the "Senior Moment" in your code.

I don't really understand what you are asking, and I am not on 2007 and the file conversion is apparently not working properly so not sure that I can help.

Brian

 

[Tanya]

Hi Brian

Thanks for the quick response.

I had noticed the 'senior moment' but it was easily fixed.
I have saved my file as an xls 2003 file so that you can take a closer look at my code. My first question is 'do I need to set up a 'change event' to envoke this code?

Since we often have movement with class numbers, the students that leave must be archived and not deleted, hence I am trying to use strikethrough.

Regards
Tanya

 

[chergh]

I think you actually need to use 2 events here, the workbook sheetchange event and the workbook sheetcalculate event.

You need the sheetchange event for when you change the value to "A" and the sheetcalculate event to update other cells which are linked to where you are changing the values.

Put the following in the ThisWorkbook module:

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)

Dim rng As Range

For Each rng In Intersect(Sh.Columns("C"), Sh.UsedRange)

    If rng.Value = "A" Then
        
        rng.EntireRow.Font.Strikethrough = True
    
    End If
    
Next rng

 
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If CBool(InStr(1, Sh.Name, "Term")) Or _
   Sh.Name = "Grades" Then

    If Not Intersect(Target, Sh.Range("C5:C44")) Is Nothing Then
    
        If Target.Value = "A" Then
            
            Target.EntireRow.Font.Strikethrough = True
        
        End If
    
    End If
    
End If

Hopefully that should do the job for you.

 

[Tanya]

Hi
Thank you for your response to my post. Unfortunately it didn't work, but that may be because I didn't understand your code and hence didn't replace anything.
Regards
Tanya

 

[chergh]

I think this is what you were wanting.

 

[Brianwarnock]

Hi Tanya

Didin't appreciate that you wanted the change refected on change, I had assumed that a block of changes would be done and then the code run from a button either on thetoobar or in the workbook.

Chergh's code is as usual good, he is better than me.
However if this is a 3D workbook with each sheet having the same ref on each row then the following code in Grades module will work, however it requires change if more TERM sheets added.

Private Sub worksheet_change(ByVal target As Range)

If Not Intersect(target, Range("C5:C44")) Is Nothing Then
    r = target.Row
        If target.Value = "A" Then
        
            
            Sheets("Grades").Rows(r & ":" & r).EntireRow.Font.Strikethrough = True
            Sheets("Term 1").Rows(r & ":" & r).EntireRow.Font.Strikethrough = True
            Sheets("Term 2").Rows(r & ":" & r).EntireRow.Font.Strikethrough = True
            'etc
        Else
            Sheets("Grades").Rows(r & ":" & r).EntireRow.Font.Strikethrough = False
            Sheets("Term 1").Rows(r & ":" & r).EntireRow.Font.Strikethrough = False
            Sheets("Term 2").Rows(r & ":" & r).EntireRow.Font.Strikethrough = False
            'etc
        End If
 End If
 
        End Sub

Brian

 

[Tanya]

Thank you Chergh, it works first time.
However, I now need to be able to protect the document and would usually refer to module1.unprotect_worksheet & module1.protect_worksheet but can't work out why I keep getting error when code realises that column H doesn't have the value A. I have tried placing these two references to module one in various stages of your code with no luck. Sorry for the hassle, could you take a peek at this for me please.

Here is the code for Module1
Sub UnProtect_Workbook()
'Unprotect workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = True Then
ws.Unprotect ("BBHS")
End If
Next
ActiveWorkbook.Unprotect (["BBHS"])
Application.ScreenUpdating = True
End Sub
Sub Protect_Workbook()
'Protect workbook
Dim ws As Worksheet
Const PWORD As String = "BBHS"
For Each ws In ActiveWorkbook.Worksheets
With ws
If ws.ProtectContents = False Then
.EnableSelection = xlUnlockedCells
.Protect Password:=PWORD
End If
End With
Next ws
ActiveWorkbook.Protect Password:=PWORD
End Sub

Thank you

Kind regards
Tanya

 

[Tanya]

Hi Brian
Thank you for this code, it worked a treat, however as with Chergh's code I keep getting a halt when column C has a value other than "A".
I feel like I am being a pain here, but I would really appreciate it if you could take a look at how I am trying to unprotect then protect my workbook and see if there is a way to get around this.
Kind regards
Tanya

 

[Tanya]

I found the answer

By removing this line:
rng.EntireRow.Font.Strikethrough = False
I have eliminated any errors and it works a treat. Now if the status of a student is changed to "A" the row is formatted to strikethrough and if I change it back to "M" or "F" the strikethrough is changed.

Thank you soooo much chergh and Brian, I couldn't have done it without you both.

Kind regards
Tanya

 

[Tanya]

When I run Chergh's code I get the following error:
"Unable to set the "strikethrough property of the font Class" hence I removed that line and all appears to work, but I have just realised when I change "A" back to "F" or "M" it doesn't update Term 1, Term 2 etc

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim rng As Range
Debug.Print Sh.Name
For Each rng In Intersect(Sh.Columns("C"), Sh.UsedRange)

If rng.Value = "A" Then
Module1.UnProtect_Workbook

rng.EntireRow.Font.Strikethrough = True


Else

rng.EntireRow.Font.Strikethrough = False 'This is the line that is causing the _
error

End If


Next rng
Module1.Protect_Workbook

End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Module1.UnProtect_Workbook
If CBool(InStr(1, Sh.Name, "Term")) Or _
Sh.Name = "Grades" Then
If Not Intersect(Target, Sh.Range("C5:C44")) Is Nothing Then

If Target.Value = "A" Then

Target.EntireRow.Font.Strikethrough = True


Else

Target.EntireRow.Font.Strikethrough = False

End If

End If



End If
Module1.Protect_Workbook
End Sub


Any suggestions?

Thanks in advance.

 

[chergh]

I thinks its just a case of including

Module1.UnProtect_Workbook

after the else statement.

 

[Tanya]

Thank you Chergh
Its working well now, I added a few lines to include instances where "A" had been changed back to "F" or "M" and after a little tinkering managed to get it to work.

Slowing but surely I am beginning to understand VBA for Excel and really appreciate your patience.

Regards
Tanya

Here is my final code:

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim rng As Range
Const PWORD As String = "BBHS"
'Unprotect workbook
Dim ws As Worksheet
Debug.Print Sh.Name
For Each rng In Intersect(Sh.Columns("C"), Sh.UsedRange)
'If column C has A then select entire row and format font to Strikethrough
If rng.Value = "A" Then
Module1.UnProtect_Workbook
rng.EntireRow.Font.Strikethrough = True

'If column C has F then select entire row and format font to Not Strikethrough
Else
If rng.Value = "F" Then
Module1.UnProtect_Workbook
rng.EntireRow.Font.Strikethrough = False

'If column C has M then select entire row and format font to Not Strikethrough
Else
If rng.Value = "M" Then
Module1.UnProtect_Workbook
rng.EntireRow.Fond.Strikethrough = False

End If
End If
End If

Next rng
Module1.Protect_Workbook

End Sub