Solved Macro to remove some text with condition and add color shade

Microsoft Excel 2010 - complete product...
February 1, 2018 at 09:02:51
Specs: Windows 7, 2,4 GHz / 4 GB
Hello,

So I made a macro to format a table. I will post the macro below and there are comments that explain things.

Here's how my table looks like: http://i65.tinypic.com/1606l5f.jpg
No, there is no shading on the cells, it's the background I use (as a Windows OS setting).
I hope the picture can be displayed.

I would like to do 2 more things, and I don't know how:
1. Remove the white text - either remove it after the conditional formatting VBA, or replace the conditional formatting VBA with some code to remove all duplicates except first occurrence from columns A and B only.

I tried several codes found online and adapted, but none worked. I'm guessing because of the conditional formatting, but dunno really.

2. Add cell color red or whatever to the entire rows that contain a client in column B, but only to those rows (they would be 2, 18 and 24 in the image).

Here is my macro without parts that I think are irrelevant to fonts and shading:

' Page setup: A4, Portrait, Center horizontally, Zoom 100%.
    With ActiveSheet.PageSetup
        .LeftMargin = Application.CentimetersToPoints(0.196850393700787)
        .RightMargin = Application.CentimetersToPoints(0.196850393700787)
        .TopMargin = Application.CentimetersToPoints(0.393700787401575)
        .BottomMargin = Application.CentimetersToPoints(0.393700787401575)
        .HeaderMargin = Application.CentimetersToPoints(0.393700787401575)
        .FooterMargin = Application.CentimetersToPoints(0.393700787401575)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 300
        .CenterHorizontally = True
        .CenterVertically = False
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = False
        .AlignMarginsHeaderFooter = False
    End With

' Conditional formatting: color in white any duplicate values, except their first appearance.
    Range("A2:A279").Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=A1=A2"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .ColorIndex = 2 ' white color
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

' Conditional formatting: color in white any duplicate values, except their first appearance.
    Range("B2:B279").Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=B1=B2"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .ColorIndex = 2 ' white color
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

' Conditional formatting font face and font size for LANDSCAPE page
' arial font by default; if you want other, add line Cell.Font.Name = "Font Name"
    For Each Cell In ActiveSheet.UsedRange
      If ActiveSheet.PageSetup.Orientation = xlPortrait Then
          Cell.Font.Size = 12                                                 ' font size for PORTRAIT
          Cell.Font.Name = "Tahoma"
      Else
          Cell.Font.Size = 16                                                 ' font size for LANDSCAPE
          Cell.Font.Name = "Tahoma"
      End If
    Next Cell


' Delete text of white color in columns A and B     ----------------------------- NOT WORKING
    Dim rng As Range
    Set rng = [B2:B279]
    For Each Cell In rng
        If Cell.Font.ColorIndex = 2 Then
        Cell.ClearContents
        End If
    Next Cell

' Add shading to row if cell with black text is in column B     ----------------------------- TBA
' TO BE ADDED

message edited by Mrrrr


See More: Macro to remove some text with condition and add color shade

Report •

#1
February 1, 2018 at 19:01:53
✔ Best Answer
You are correct in your assumption that the CF font color is not the same as the Font.ColorIndex. A CF Fill color is not the same as the Interior.ColorIndex either. Therefore, you cannot "test" a cell via VBA for those colors.

If you want to find cells that have been Conditionally Formatted, you basically have to search for cells that meet the criteria that set the CF. VBA can set CF and clear CF, but it can't find CF'd cells by searching for CF'd formats.

Now, in your case, you appear to have an option. Replace this...

' Delete text of white color in columns A and B     ----------------------------- NOT WORKING
    Dim rng As Range
    Set rng = [B2:B279]
    For Each Cell In rng
        If Cell.Font.ColorIndex = 2 Then
        Cell.ClearContents
        End If
    Next Cell

...with this, and both of your requirements will be met (for Column B, at least)

'Delete duplicate entries, Apply Red fill to Row of remaining entry
For rw = 279 To 2 Step -1
 If Cells(rw, 2) = Cells(rw - 1, 2) Then
  Cells(rw, 2).ClearContents
 Else: Cells(rw, 2).EntireRow.Interior.ColorIndex = 3
 End If
Next


How To Post Data or Code ---> Click Here Before Posting Data or VBA Code

message edited by DerbyDad03


Report •

#2
February 4, 2018 at 22:31:30
Hello,

Thanks for the quick answer and sorry for not getting back to you sooner. Windows updates from hell made my PC work slower than ever, been waiting 1-2 minutes for the macro to actually do something. Even now I dunno what's happening, after IT uninstalled some NET framework update because I couldn't even print documents.

It's not because of your code, of course. It's weird though that after 2 minutes while everything freezes, then it says there's an error in the page formatting section of the code, random lines: .PrintQuality the 1st time, then it worked. Now it's got a problem with .FooterMargin. This is weird as Thursday it worked fine, I ran this code like 100 times. Now it's having a problem with every line under pagesetup. This is effing annoying and I can't do anything about it, because of IT security.

Back to that code, I managed to run it once without errors and saw it made the whole rows red. I only need to limit the color fill to only columns A:E of those rows. I tried a range instead of EntireRow but now I can't test it. I guess I will have to get the file and vba code at home and try, because it seems nothing works anymore.

What I also noticed is that it colored another row, a blank row at the end of the table. I'm guessing it's not random, because the last row of the table has text in column B, so I am guessing that the next row being different, it gets colored, doesn't matter if no content.

I will get back at you tonight, but please tell me if my modification is correct and if the code will do fill for only A:E rows (except for the blank row fill):

'Delete duplicate entries, Apply Red fill to Row of remaining entry
For rw = 279 To 2 Step -1
 If Cells(rw, 2) = Cells(rw - 1, 2) Then
  Cells(rw, 2).ClearContents
 Else: Cells(rw, 2).Range("A:E").Interior.ColorIndex = 3
 End If
Next

Edit:
Hmm, then again it could freeze because of the code. I just tested the email sending macro and it worked in 1 second, while this macro now it's freezing excel and I have to wait 2-3 minutes for it to work. I'm gonna post it below, maybe you can spot some problem because I can't see it. I disabled your code and ran it like I did 100 times on Thursday, but still freezes.
I have to mention something else I didn't mention before as I didn't think it's relevant: I saved my macro to PERSONAL.XLSB instead of the excel file, so I can run it in every newly generated documents (because I need it to be dynamic and work in normal excel file format, without the need of a macro enabled one). Dunno if this could be a problem...

Sub Printing()
'
' Macro to format page for printing ------ GO AT THE BOTTOM TO CHOOSE IF YOU WANT TO 
' PRINT DIRECTLY OR PREVIEW FIRST

' ########### -- LANDSCAPE / PORTRAIT -- ###########

' Choose between landscape and portrait format (add ' in front of the line that you don't want to 
' use and remove it from the other line)
    With ActiveSheet.PageSetup
        .Orientation = xlPortrait                                       ' portrait
        '.Orientation = xlLandscape                                      ' landscape
    End With

' #################################

' In cells E1 and D1 the values must be changed. My table will always be the same: 5 columns, 
' starting from A1 to E1, variable
' length but never longer than about 250, always presorted ascending by column B
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Um"
    ActiveCell.WrapText = False
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Cant"
    ActiveCell.WrapText = False
    
' If multiple pages, you will print table header on each page.
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:1"
        .PrintTitleColumns = ""
    End With

' Page setup: A4, Portrait, Center horizontally, Zoom 100%.
    With ActiveSheet.PageSetup
        .LeftMargin = Application.CentimetersToPoints(0.196850393700787)
        .RightMargin = Application.CentimetersToPoints(0.196850393700787)
        .TopMargin = Application.CentimetersToPoints(0.393700787401575)
        .BottomMargin = Application.CentimetersToPoints(0.393700787401575)
        .HeaderMargin = Application.CentimetersToPoints(0.393700787401575)
        .FooterMargin = Application.CentimetersToPoints(0.393700787401575)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 300
        .CenterHorizontally = True
        .CenterVertically = False
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = False
        .AlignMarginsHeaderFooter = False
    End With

' Replace AAAAAAAA with AAA
    ActiveSheet.Columns("B").Replace _
    What:="AAAAAAAA", Replacement:="AAA", _
    SearchOrder:=xlByColumns, MatchCase:=True

' Replace MAGAZINE with Mag
    ActiveSheet.Columns("B").Replace _
    What:="MAGAZINE", Replacement:="Mag", _
    SearchOrder:=xlByColumns, MatchCase:=True
    
' Replace PRAKTIKER with PRK
    ActiveSheet.Columns("B").Replace _
    What:="PRAKTIKER", Replacement:="PRK", _
    SearchOrder:=xlByColumns, MatchCase:=True
    
' Replace CONSTANT with CT
    ActiveSheet.Columns("B").Replace _
    What:="CONSTANT", Replacement:="CT", _
    SearchOrder:=xlByColumns, MatchCase:=True
    
' Replace BUCHAREST with BUC
    ActiveSheet.Columns("B").Replace _
    What:="BUCHAREST", Replacement:="BUC", _
    SearchOrder:=xlByColumns, MatchCase:=True
    
' Replace BUC with BC
    ActiveSheet.Columns("E").Replace _
    What:="BUC", Replacement:="buc", _
    SearchOrder:=xlByColumns, MatchCase:=True

'Delete duplicate entries in row 2, Apply Red fill to Row of remaining entry
For rw = 279 To 2 Step -1
 If Cells(rw, 2) = Cells(rw - 1, 2) Then
  Cells(rw, 2).ClearContents
 Else: Cells(rw, 2).EntireRow.Interior.ColorIndex = 3
 End If
Next

'Delete duplicate entries in row 1
' For rw = 279 To 2 Step -1
' If Cells(rw, 1) = Cells(rw - 1, 1) Then
'  Cells(rw, 1).ClearContents
' End If
' Next

    If ActiveSheet.PageSetup.Orientation = xlPortrait Then
' Set column sizes for PORTRAIT pages                               PORTRAIT column sizes
    Columns("A:A").Select
    Selection.ColumnWidth = 11
    Columns("B:B").Select
    Selection.ColumnWidth = 29
    Columns("C:C").Select
    Selection.ColumnWidth = 44
    Columns("D:D").Select
    Selection.ColumnWidth = 12
    Columns("E:E").Select
    Selection.ColumnWidth = 4
    Else
' Set column sizes for LANDSCAPE pages                                LANDSCAPE column sizes
    Columns("A:A").Select
    Selection.ColumnWidth = 14
    Columns("B:B").Select
    Selection.ColumnWidth = 42
    Columns("C:C").Select
    Selection.ColumnWidth = 60
    Columns("D:D").Select
    Selection.ColumnWidth = 20
    Columns("E:E").Select
    Selection.ColumnWidth = 7
    End If
    
' Conditional formatting font face and font size for LANDSCAPE page
' arial font by default; if you want other, add line Cell.Font.Name = "Font Name"
    For Each Cell In ActiveSheet.UsedRange
      If ActiveSheet.PageSetup.Orientation = xlPortrait Then
          Cell.Font.Size = 12                       ' font size for PORTRAIT
          Cell.Font.Name = "Tahoma"
      Else
          Cell.Font.Size = 16                          ' font size for LANDSCAPE
          Cell.Font.Name = "Tahoma"
      End If
    Next Cell

' Add table borders for all cells with content.
    With ActiveSheet.UsedRange.Borders
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .Weight = xlThin
    End With

' ########### -- PRINTING -- ###########

' Print preview or print directly (add ' in front of the line that you don't want to use and 
' remove it from the other line)
'        Application.CommandBars.ExecuteMso ("PrintPreviewAndPrint")  ' PRINT PREVIEW FIRST
'        ActiveSheet.PrintOut                   ' PRINT IMMEDIATELY ON DEFAULT PRINTER
        
' #################################

        Range("A1").Select

End Sub

message edited by Mrrrr


Report •

#3
February 5, 2018 at 04:41:58
2 things come to mind even before I test anything:

1 - Do you really need to set all of the formats that you are setting? If any of them are defaults, then don't waste VBA resources setting them.

2 - Maybe you just don't show it, but are you using this instruction?

Application.ScreenUpdating = False

Doing all of that formatting and data deletion "live" can really slow the code down. Let VBA do it in the background and then apply it all at once.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Report •

Related Solutions

#4
February 5, 2018 at 05:59:27
1 - Cleared all unnecessary / default code, all of which was under ActiveSheet.PageSetup.

2 - Wasn't using that. This macro started existing after I used the record macro button, then edited. That's why much default code and no use of that instruction. As mentioned, I am a beginner. Anyway, added at start

Application.ScreenUpdating = False 

and added at end

Application.ScreenUpdating = True

So I am left with a part for page setup, a bit of text replace in cells D1 and E1, some text replacements in column B to shorten names, the code you made for me, font name and size, adding borders to used range, between the 2 lines above.

Running the macro starts process splwow64.exe (obviously because of page setup), and this is what was causing me problems Friday and today all day long. I can't print anything from any software whatsoever without killing that service.

Killed it and the macro worked, but it's still doing rows red until column SFD, obviously, and still painting first empty row below the table (I can live with that if we paint it 5 columns only).

It was weird why it would slow down all of a sudden when Thursday I practically killed the run macro button (had made custom button in quick access toolbar).

Thanks!


Report •

Ask Question