• 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...

  • 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

bkanne

Member
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
 
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.
 
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.
 
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 …
 
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.
 
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:
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
 

Attachments

  • Sample_Workbook_v1.xlsm
    24 KB · Views: 5
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:
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:
Would this do it?
Code:
Sub PasteAsPicture()
Selection.Copy
Range("C19").Activate
ActiveSheet.Pictures.Paste
Application.CutCopyMode = False
End Sub
 
Would this do it?
Code:
Sub PasteAsPicture()
Selection.Copy
Range("C19").Activate
ActiveSheet.Pictures.Paste
Application.CutCopyMode = False
End Sub

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

Thanks anyhow,
Ben
 
Hi ,

For your font color change , use the following loop :
Code:
    For Each cell In Selection
        With cell.Font
            If .Color <> 16777215 Then .Color = -16777216
            .TintAndShade = 0
        End With
    Next
Narayan
 
Try this; It's a combination of several of the above offerings. It should deal with row heights and hidden rows.
Code:
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
 
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.
 
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:
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
 
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
 
Updated to prevent name errors from creating an alert box when copying the original tab.

Code:
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
 
Back
Top