View Full Version : Need Assistance with Text Font Color Change
tjc154
08-29-2009, 12:27 AM
I have two sections of code that alter text font color based on a set criteria.The first piece of code (apps that require admin rights) works as expected. The issue is the with the second group of code (See the code below) that starts with the following string:
'Now highlight the apps that are non certified
I have two worksheets; one called RevisedAppList and another called CertifiedApps. What I would like to do is have the font color change to "Blue" under the Revised AppList tab if an application is not listed under the CertifiedApps worksheet. I tried several variations of the code, but did not have any success. The macro executes without errors but does not produce the desired results.
Any thoughts on what needs to be modified in order for the script to run properly?
Thanks,
Tom
'Now highlight the apps that require admin rights
iListCount = 0
iCtr = 0
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("RevisedAppList").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("Admin").Range("A1:A" & Sheets("Admin").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 2 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("RevisedAppList").Cells(iCtr, 1).Value Then
' If match is true then delete row.
'Sheets("RevisedAppList").Cells(iCtr, 1).EntireRow.Delete
Sheets("RevisedAppList").Cells(iCtr, 1).Font.Color = RGB(255, 0, 0)
End If
Next iCtr
Next
Application.ScreenUpdating = True
'Now highlight the apps that are non certified
iListCount = 0
iCtr = 0
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("RevisedAppList").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("CertifiedApps").Range("A1:A" & Sheets("CertifiedApps").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 2 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("RevisedAppList").Cells(iCtr, 1).Value Then
' If match is true then delete row.
'Sheets("RevisedAppList").Cells(iCtr, 1).EntireRow.Delete
Sheets("RevisedAppList").Cells(iCtr, 1).Font.Color = 0 - 0 - 255
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Core Applications and Certified applications have been removed!"
MsgBox "Applications requiring admin rights have been marked in RED!"
MsgBox "Non Certified Applications have been marked in BLUE!"
End Sub
p45cal
08-29-2009, 01:36 AM
I'm a bit dubious abouit the line ending
.Font.Color = 0 - 0 - 255
which is the same as saying:
.Font.Color = -255
but I suspect you meant:
.Font.Color = RGB(0,0,255)
If that's not the problem, start by putting the cursor on that same line and press the F9 key to put in a break. Run the code again. Does it stop at that line? If not then that line never gets executed and you'll have to check what's being looked at in the code (though make sure that that there actually is a match to be found!).
tjc154
08-29-2009, 04:53 AM
You are correct,the code is not executing because it runs through without any errors even when using F9 at that line. It make sense, because there is no matching criteria.
Per my initial comments, I'm not sure how to write the code so it changes the font color if the criteria does not match. Looking at the code below, I need to re write the statement that is bolded.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("RevisedAppList").Cells(iCtr, 1).Value Then
' If match is true then delete row.
'Sheets("RevisedAppList").Cells(iCtr, 1).EntireRow.Delete Sheets("RevisedAppList").Cells(iCtr, 1).Font.Color = RGB(0, 0, 255)
Does that help?
Thanks,
Tom
p45cal
08-29-2009, 06:29 AM
I missed that, sorry. Try this (untested, but it should work):iListCount = Sheets("RevisedAppList").Cells(Rows.Count, "A").End(xlUp).Row
For iCtr = iListCount To 2 Step -1
MatchFound = False
For Each x In Sheets("CertifiedApps").Range("A1:A" & Sheets("CertifiedApps").Cells(Rows.Count, "A").End(xlUp).Row)
If x.Value = Sheets("RevisedAppList").Cells(iCtr, 1).Value Then
MatchFound = True
Exit For 'only to speed things up a bit, once match found, no need to go on looking.
End If
If Not MatchFound Then
Sheets("RevisedAppList").Cells(iCtr, 1).Font.Color = RGB(0, 0, 255) 'delete or comment-out after testing and enable next line
'Sheets("RevisedAppList").Rows(iCtr).Delete
End If
Next x
Next iCtr
tjc154
08-29-2009, 09:04 AM
To clarify, should I replace the code I currently have in place with the code you provided or do I need to add this starting on a specific line.
I tried replacing the code and everything highlighted Blue in the RevisedAppList Worksheet?
Here's my original code.
'Now highlight the apps that are non certified
iListCount = 0
iCtr = 0
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("RevisedAppList").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("CertifiedApps").Range("A1:A" & Sheets("CertifiedApps").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 2 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("RevisedAppList").Cells(iCtr, 1).Value Then
' If match is true then delete row.
'Sheets("RevisedAppList").Cells(iCtr, 1).EntireRow.Delete
Sheets("RevisedAppList").Cells(iCtr, 1).Font.Color = RGB(0, 0, 255)
End If
Next iCtr
Next
Application.ScreenUpdating = True
Please advise,
Thanks,
Tom
p45cal
08-29-2009, 09:49 AM
It's to replace the second part of your code, the bit you said wasn't working, there are comments in the code. Yes, replace all the code you included in your last post with the code I supplied, but you could add back the Application.ScreenUpdating=True/False lines if you want.
You said:"It make sense, because there is no matching criteria."
You also said:"to write the code so it changes the font color if the criteria does not match"
So wouldn't you expect all the rows to be blue?
Now just remove the apostrophe to uncomment the line
Sheets("RevisedAppList").Rows(iCtr).Delete
and add an apostrophe to the beginning of the line colouring the font blue to disable it so that then when you run the macro again the lines should all be deleted instead of being coloured blue.
I can't test because I can't see your data; when your post count here reaches 5 you'll be able to attach a sample file.
Aussiebear
08-29-2009, 02:41 PM
Actually Tom should be able to attach a file now, he just won't be ale to attach hyperlinks.
tjc154
08-29-2009, 04:18 PM
I will post my worksheet later this evening, so it makes it easier to test the code.
Thank you again for all your help. I'm a novice to VBA and slowly trying to learn my way through writing code in VBA.
Tom
tjc154
08-29-2009, 07:15 PM
Please find attached the spreadsheet that I'm working from. I tried the code you provided, but something seems to be looping because my Excel froze up for 20 or 30 seconds until the macro was finished running and it deleted all data under the RevisedAppsList tab. I put back my old code.
In your last response you mentioned the following
You also said:"to write the code so it changes the font color if the criteria does not match"
So wouldn't you expect all the rows to be blue?
To answer your question about- wouldn't you expect all the rows to be blue. If an application listed under the RevisedAppList worksheet is not listed under the CertifiedApps tab, the font should change to Blue for that row. All other rows should remain in their current font and not be deleted if they match the applications listed under the CertifiedApps tab. Hope that clarifies what I am looking to do.
As an example in the attached spreadsheet, I entered an application called DIVX player on the RevisedAppsList tab. When the code was run it should have left it in place and changed the font to blue since it was not a match.
Thanks,
Tom
mdmackillop
08-30-2009, 05:26 AM
Rather than looping both sheets, use Find for each value in one sheet.
Option Explicit
Sub AddNewThree()
Dim iListCount As Integer
Dim iCtr As Integer
Dim oRng
Dim RevAmp As Range, r As Range
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
With Sheets("RevisedAppList")
' Look for each value; if found, delete it.
Set RevAmp = Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
Call DelApps(RevAmp, Sheets("CoreAppList"))
Call DelApps(RevAmp, Sheets("CertifiedApps"))
' Look for each value in Admin; if found, make it Red, else make it Blue
Call ColApps(RevAmp, Sheets("Admin"))
End With
MsgBox "Core Applications and Certified applications have been removed!"
MsgBox "Applications requiring admin rights have been marked in RED!"
MsgBox "Non Certified Applications have been marked in BLUE!"
End Sub
Sub DelApps(RevAmp As Range, sh As Worksheet)
Dim i As Long, c As Range
For i = RevAmp.Cells.Count To 1 Step -1
Set c = sh.Columns(1).Find(RevAmp(i), lookat:=xlWhole)
If Not c Is Nothing Then RevAmp(i).EntireRow.Delete
Next
End Sub
Sub ColApps(RevAmp As Range, sh As Worksheet)
Dim r As Range, c As Range
For Each r In RevAmp
Set c = sh.Columns(1).Find(r, lookat:=xlWhole)
If Not c Is Nothing Then
r.Font.Color = RGB(255, 0, 0)
Else
r.Font.Color = RGB(0, 0, 255)
End If
Next
End Sub
tjc154
08-30-2009, 07:56 AM
All,
Thank you everyone for your assistance. Both solutions worked as expected. After a good nights rest I reviewed the data under several tabs and found some inconsistencies with the application names. I have since fixed these name discrepancies and everything is working as well.
Apparently the database's that I am pulling the application names from report their findings slightly different which confused things when the code ran.
Thank you again.
Tom
p45cal
08-30-2009, 09:40 AM
A bit late in the day but..
Well, it looks as if the entire list should be blue, because earlier on in the code you remove all certified apps, leaving only non certified ones.
I have made adjustments to your code in the attached file in the 4th of the four loops to highlight in blue those apps not found in the CertifiedApps list. This is, of course, all of them - including those which had previously been highlighted in red for being found in the Admin list.
I don't think you want this. One solution here is to highlight non certified apps in a different way, say by changing the colour of the cell. I added commented-out lines suggestions to replace yours in 2 places.
You're going at this back to front. The list produced from LARS is likely to be smaller than the other lists. How would you do it manually, with paper printouts of all lists? To exaggerate, say your pasted list from LARS consisted of only 2 entries. Suppose the lists of Core apps, Certified apps and Admin Apps each had about 1000 entries each, each in its lever-arch file. Naturally, you would look at the LARS list, take the first entry and look it up in each of the larger lists and as soon as you came across it you highlight it appropriately or put a line through it. Then you'd do the same with the second and last entry in the LARS list. Job done.
What your code did, in manual terms, is pick up the first of the lever-arch files, look at the first entry in that, then look at your 2 entries in the LARS list and highlight/delete if necessary. Then you move to the second entry in the big list, and again look at the 2 entries in the LARS list. Then you move to the third entry in the big list.. ..you keep doing that even if both LARS entries have been highlighted, working your way through the entire list of 1000 entries. Then you pick up the second lever-arch file and start again...etc.
I've added a new sub (sub blah())which could replace all the functionality of your sub. It runs through your LARS list, from the bottom:
1.Looks to see if it's in the Core App list and if it is, deletes that row and moves straight on to the next item in the LARS list.
2.If not found in the Core Apps list it looks to see if it's in the CertifiedApps list and if it is, deletes that row and moves straight on to the next item in the LARS list.
3.If not found in the CertifiedApps list it looks in the Admin list and if found it colours the font red.
Nothing is done about highlighting non-certified apps as thay are all so.
Are the lists all mutually exclusive? (Can one item appear on more than one list?) If so you may want to do something a bit different. What to do if an app is not certified but needs admin privileges (can it be so?)?
Checking for version numbers is not done, but with a bit more coding could be.
The code for Sub Blah():Sub blah()
Dim iCtr As Long, xxx As Range
Dim CoreListRng As Range, CertAppsListRng As Range, AdminListRng As Range
'create 3 ranges to search:
Set CoreListRng = Intersect(Sheets("CoreAppList").UsedRange, Sheets("CoreAppList").Columns(1))
Set CertAppsListRng = Intersect(Sheets("CertifiedApps").UsedRange, Sheets("CertifiedApps").Columns(1))
Set AdminListRng = Intersect(Sheets("Admin").UsedRange, Sheets("Admin").Columns(1))
For iCtr = Sheets("RevisedAppList").Cells(Sheets("RevisedAppList").Rows.Count, "A").End(xlUp).Row To 2 Step -1
Set xxx = CoreListRng.Find(What:=Sheets("RevisedAppList").Cells(iCtr, 1).Value, LookIn:=xlFormulas, lookat:=xlWhole, MatchCase:=False)
If Not xxx Is Nothing Then 'found in Core Apps
Sheets("RevisedAppList").Rows(iCtr).Delete 'and abandon searching any other list
Else 'not found in Core Apps
Set xxx = CertAppsListRng.Find(What:=Sheets("RevisedAppList").Cells(iCtr, 1).Value, LookIn:=xlFormulas, lookat:=xlWhole, MatchCase:=False)
If Not xxx Is Nothing Then 'found in Cert Apps
Sheets("RevisedAppList").Rows(iCtr).Delete 'and abandon searching any other list
Else 'not found in Cert Apps
Set xxx = AdminListRng.Find(What:=Sheets("RevisedAppList").Cells(iCtr, 1).Value, LookIn:=xlFormulas, lookat:=xlWhole, MatchCase:=False)
If Not xxx Is Nothing Then 'found in Admin
Sheets("RevisedAppList").Cells(iCtr, 1).Font.Color = RGB(255, 0, 0)
End If
End If
End If
Next iCtr
End Sub
tjc154
09-02-2009, 12:36 PM
Now that I have gotten most of the code worked out, I’m trying to make some final format changes to how the data looks under the RevisedAppList after the macro runs.
I provided two attachments showing current format and proposed format. In the proposed format, I would like to do the following.
The column headers in row 2 should remain after the macro runs. Currently they get deleted.
Next, I would like any apps not listed under the Admin tab to populate under the Uncertified Installed Applications column, Apps requiring admin rights and their versions to populate in the adjoining columns, etc.
Next, I would like to create a break line whenever the machine name and username changes. When I first run the macro I populate the revised app list tab with data from multiple machines.
Lastly, I tried modifying the code so it would show all retired applications in Green Font, but somewhere I’m getting tripped up on the last sub routine. I added a third line r.Font.Color = RGB (0,100,0) for green but it generates an error.
If Not c Is Nothing Then
r.Font.Color = RGB(0, 0, 255)
Else
r.Font.Color = RGB(255, 0, 0)
End If
Next
End Sub
I’m not sure if the above logic can be built using VBA.
Please let me know if this makes sense.
Thanks again.
Tom
tjc154
09-02-2009, 12:37 PM
Here's the proposed format
mdmackillop
09-02-2009, 01:03 PM
Try
Sub ColApps(RevAmp As Range, sh As Worksheet)
Dim r As Range, c As Range
Select Case sh.Name
Case "Admin"
For Each r In RevAmp
Set c = sh.Columns(1).Find(r, lookat:=xlWhole)
If Not c Is Nothing Then
r.Font.Color = RGB(0, 0, 255)
Else
r.Font.Color = RGB(255, 0, 0)
End If
Next
Case "RetiredApps"
For Each r In RevAmp
Set c = sh.Columns(1).Find(r, lookat:=xlWhole)
If Not c Is Nothing Then
r.Font.Color = RGB(0, 100, 0)
End If
Next
End Select
End Sub
tjc154
09-03-2009, 01:20 AM
Thanks, the code worked perfectly for the green color font change. What are your thoughts on the formatting changes I'm trying to implement. Does it sound like something VBA can accomplish?
Tom
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.