1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Change Font Colors to Black, Copy/Paste as Enhanced Metafile, Return Font Colors to Original

Discussion in 'VBA Macros' started by bkanne, Nov 9, 2017.

  1. bkanne

    bkanne Member

    Messages:
    53
    Hi all,

    I'm looking for help with a multiple step macro that will perform the following steps on a selection in Excel:

    • Change all non-black or white font colors to black
    • Copy and paste the selection (with all black font colors) as an enhanced metafile
    • Revert all cell font colors to their original color
    I'm a big fan of color coding spreadsheets (links to other worksheets are green, inputs are blue, etc) but it looks poor when putting an output into PowerPoint for example. This macro would allow one to keep their spreadsheets color coded as they like and still have clean outputs.

    Thank you so much for any help!

    Regards,
    Ben
  2. vletm

    vletm Well-Known Member

    Messages:
    2,854
    Ben
    1) Make a copy from that sheet
    2) Set all its font colors to black
    3) Copy and paste Your selections as You like
    4) Delete that new sheet ( then no need to revert the original)
    You could do that even with Macro Recorder.
    Marc L likes this.
  3. bkanne

    bkanne Member

    Messages:
    53
    Thanks for the reply.

    The fonts that won't change color are black and white, so it's not just a matter of changing all the colors to black and then deleting the sheet. One would have to actively discern which cells are white and avoid selecting those so they remain unadjusted and aren't made black.

    I'd also like to avoid adding and deleting new sheets if possible. I've seen this process automated on a single sheet with add-ins, so I'm certain that it's possible.
  4. Marc L

    Marc L Excel Ninja

    Messages:
    3,225
    Hi !

    The smart way is to not mod original worksheet,
    so like written by vletm ‼

    Just think about a crash during procedure,
    no matter with this way but with your desired way
    it's insane 'cause of mod of cells without any way to revert them !

    And again better than font color is to discern cells by data,
    so much clever and efficient !

    Try filter way, even on color if you use a not too old Excel version …
  5. bkanne

    bkanne Member

    Messages:
    53
    Understood on the first point.

    On the second point, there is no way to discern the cells by data in this instance, it needs to be done by color.
  6. vletm

    vletm Well-Known Member

    Messages:
    2,854
    bkanne
    Do You know which cells fonts are white?
  7. NARAYANK991

    NARAYANK991 Excel Ninja

    Messages:
    15,817
    Hi ,

    Can you upload a sample workbook ?

    Narayan
  8. bkanne

    bkanne Member

    Messages:
    53
    Sure Narayan - I've attached a sample workbook.

    I've written the attached code, which is doing exactly what I want it to do, except that it can't handle font colors that should not be changed to black (i.e. white).

    Code (vb):
    Sub Test()

    Dim myCells As Range
    Set myCells = Selection
    myCells.Copy

    Sheets.Add After:=ActiveSheet

    Selection.PasteSpecial xlPasteValuesAndNumberFormats
    Selection.PasteSpecial xlPasteFormats
    Selection.PasteSpecial xlPasteColumnWidths

        With Selection.Font
            .Color = -16777216
            .TintAndShade = 0
        End With

    ActiveWindow.DisplayGridlines = False

    Dim myCells2 As Range
    Set myCells2 = Selection
    myCells2.Copy

    ActiveSheet.Previous.Select

    ActiveSheet.Pictures.Paste.Select

    ActiveSheet.Next.Select

    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True

    ActiveSheet.Previous.Select

    End Sub
    Can someone please help me change the code here so that fonts in white do not get picked up and changed to black?

    Thanks so much,
    Ben

    Attached Files:

  9. bkanne

    bkanne Member

    Messages:
    53
    Made a slight alteration to the code. Now this should only copy and paste visible rows/columns within the selection.

    One additional issue that I'm having is that I'm unable to keep the row heights the same. Can someone help me 1) prevent the fonts that are already white from changing to black, and 2) also copy the row heights of the selection?

    I would really appreciate any guidance here!

    Thanks so much,
    Ben

    Code (vb):
    Sub Test()

    Dim myCells As Range
    Set myCells = Selection
    myCells.SpecialCells(xlCellTypeVisible).Copy

    Sheets.Add After:=ActiveSheet

    Selection.PasteSpecial xlPasteColumnWidths
    Selection.PasteSpecial xlPasteValues
    Selection.PasteSpecial xlPasteValuesAndNumberFormats
    Selection.PasteSpecial xlPasteFormats


        With Selection.Font
            .Color = -16777216
            .TintAndShade = 0
        End With

    ActiveWindow.DisplayGridlines = False

    Dim myCells2 As Range
    Set myCells2 = Selection
    myCells2.Copy

    ActiveSheet.Previous.Select

    ActiveSheet.Pictures.Paste.Select

    ActiveSheet.Next.Select

    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True

    ActiveSheet.Previous.Select

    End Sub
     
    Thanks so much,
    Ben
    Last edited: Nov 13, 2017
  10. p45cal

    p45cal Well-Known Member

    Messages:
    884
    Would this do it?
    Code (vb):
    Sub PasteAsPicture()
    Selection.Copy
    Range("C19").Activate
    ActiveSheet.Pictures.Paste
    Application.CutCopyMode = False
    End Sub
     
  11. bkanne

    bkanne Member

    Messages:
    53
    No, it would not. This code doesn't do anything to change the font colors to black.

    Thanks anyhow,
    Ben
  12. NARAYANK991

    NARAYANK991 Excel Ninja

    Messages:
    15,817
    Hi ,

    For your font color change , use the following loop :
    Code (vb):

        For Each cell In Selection
            With cell.Font
                If .Color <> 16777215 Then .Color = -16777216
                .TintAndShade = 0
            End With
        Next
     
    Narayan
    bkanne likes this.
  13. p45cal

    p45cal Well-Known Member

    Messages:
    884
    You could have provided some colour in your sampe file, instead of just black and white fonts!
    Last edited: Nov 14, 2017
  14. p45cal

    p45cal Well-Known Member

    Messages:
    884
    Try this; It's a combination of several of the above offerings. It should deal with row heights and hidden rows.
    Code (vb):
    Sub PasteAsPicture()
    Set origSht = ActiveSheet
    ActiveSheet.Copy after:=Sheets(Sheets.Count)
    Set NewSht = ActiveSheet
    For Each cll In Selection.Cells
      With cll.Font
        If .Color <> 16777215 Then .Color = -16777216
        '.TintAndShade = 0 'you might get away without this.
     End With
    Next
    Selection.Copy
    Application.Goto origSht.Range("C19")
    ActiveSheet.Pictures.Paste
    Application.DisplayAlerts = False: NewSht.Delete: Application.DisplayAlerts = True
    End Sub
    bkanne likes this.
  15. bkanne

    bkanne Member

    Messages:
    53
    p45cal - this is genius, it works exactly as I had hoped. thank you so much!

    you are also correct, I should have been more clear with my sample file.
  16. bkanne

    bkanne Member

    Messages:
    53
    I also two more minor features for anyone interested.

    1. Comment indicators are no longer picked up in the image as well
    2. The recently created image is also copied to the clipboard after creation (to be pasted into PowerPoint, Word, etc). One could also set this to delete the image from Excel if desirable.
    Thanks again for all the help on this all.

    Code (vb):
    Sub PasteAsPicture()
    Application.DisplayCommentIndicator = xlNoIndicator
    Set origSht = ActiveSheet
    ActiveSheet.Copy after:=Sheets(Sheets.Count)
    Set NewSht = ActiveSheet
    For Each cll In Selection.Cells
      With cll.Font
        If .Color <> 16777215 Then .Color = -16777216
        '.TintAndShade = 0 'you might get away without this.
    End With
    Next
    Selection.Copy
    Application.Goto origSht.Range("C19")
    ActiveSheet.Pictures.Paste
    ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Copy
    Application.DisplayAlerts = False: NewSht.Delete: Application.DisplayAlerts = True
    Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    End Sub


     
  17. bkanne

    bkanne Member

    Messages:
    53
    Would it be possible to add the following condition?

    Before the image is copied (switch all views to normal view)
    • If the ActiveWindow.View = xlNormalView, Then Keep xlNormalView
    • If the ActiveWindow.View = xlPageBreakPreview, then Switch to xlNormalView
    • If any other view, switch to xlNormalView
    After the image is copied (return view to original state)
    • If the Original View was xlPageBreakPreview, Go Back to xlPageBreakPreview
    • If Original View was any other view, go back to whatever that view was
    Thanks again!
    Ben
  18. bkanne

    bkanne Member

    Messages:
    53
    Updated to prevent name errors from creating an alert box when copying the original tab.

    Code (vb):
    Sub PasteAsPicture2()
    Application.DisplayCommentIndicator = xlNoIndicator
    Application.DisplayAlerts = False
    Set origSht = ActiveSheet
    ActiveSheet.Copy after:=Sheets(Sheets.Count)
    Set NewSht = ActiveSheet

    For Each cll In Selection.Cells
      With cll.Font
        If .Color <> 16777215 Then .Color = -16777216
        '.TintAndShade = 0 'you might get away without this.
    End With
    Next

    Selection.Copy
    Application.Goto origSht.Range("A1")
    ActiveSheet.Pictures.Paste
    ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Copy
    Application.DisplayAlerts = False: NewSht.Delete: Application.DisplayAlerts = True
    Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Delete
    Application.DisplayAlerts = True
    End Sub
     

Share This Page