Copy current color of conditional formatted cell

[justme]

Hi y'all,

I have a button on sheet "Master" that calls a sub to copy the contents of
sheet "Master" to sheet "FitterSurvey"--values and formatting only.

Public Sub FS_CreateFitterSurvey()
'
' Copies data from Master sheet to Fitter Survey sheet
'
On Error GoTo ErrorHandler

Dim Master As Worksheet
Dim FitterSurvey As Worksheet

Set Master = ActiveWorkbook.Sheets("Master")
Set FitterSurvey = ActiveWorkbook.Sheets("FitterSurvey_XXXXX")

Master.Activate
With Master
Cells.Select
Selection.Copy
End With

With FitterSurvey.Range("A1")
..PasteSpecial xlValues
..PasteSpecial xlFormats
End With

Master.Activate
Range("A1").Select
FitterSurvey.Activate
Range("A1").Select

End Sub


I need help with two problems:

1) some of the cells on the origin sheet are conditionally formatted to turn
pink based on value.

For example:
Cell B3 on sheet "Master"
Cell N3 on sheet "Person"

Cell B3's formula is:
=IF(ISBLANK('(Person)'!N3),"Please enter your title here",'(Person)'!N3)

Then, conditional formatting kicks in and based on a cell value of "Please
enter your title", it will turn B3 text color pink instead of automatic.

Then, after I use the sub above to copy the values and formats of the whole
page to "FitterSurvey". B3 on FitterSurvey remains pink due to the copied
over conditional formatting.

However, what I would really like is for B3 on FitterSurvey, whether it is
pink or black, to remain pink (or automatic) from now on, no matter what the
value (normal text color = pink or normal color = automatic).

Can this be solved either during the copy paste process, or after the paste,
to convert the normal color of the cell text to whatever it currently is
under conditional formatting?


2) The "Master" sheet will contain pictures or drawing objects, but they're
changing all the time. So, when I use the above macro to copy over the
contents, I would like for it to copy any objects over to the FitterSurvey
sheet, in the *exact same positions*. I have tried different things I've
seen in posts, but I can not get them to work correctly in my sub.

I adapted the following code from Peter T to my sub, but the pictures all
pasted starting in cell A1 for some reason. They were, however, correctly
positioned relative to each other.

Sub CopyAllPictures()
Dim r As Long, c As Long
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim pic As Picture

Set wsSource = Worksheets("Sheet1")
Set wsDest = Worksheets("Sheet2")

r = wsSource.Rows.Count
c = wsSource.Columns.Count

For Each pic In wsSource.Pictures
With pic.TopLeftCell
If .Row < r Then r = .Row
If .Column < c Then c = .Column
End With
Next

wsDest.Activate
wsDest.Cells(r, c).Activate

wsSource.Pictures.Copy
wsDest.Paste

wsDest.Cells(r, c).Activate

End Sub

 

[Peter T]

If I follow your first question, you want to copy values & formats (excl
CF's) between sheets, and where any CF formats have kicked in copy the
resulting format too.

This requires evaluating the True/false state of all the CF cells and the
format applied if True for each cell. This might be very simple if you know
both the condition to evaluate and the format to be applied as in the highly
contrived example below. Otherwise you need to read one or two of the CF
formulas with operators(s), together with format for up to 3 conditions.
This can get quite tricky to get all conceivable results particularly where
non relative cells are used in formulas (A1 vs $A$1).

Following assumes you know the all CF's on the source sheet are like this

Cell Value Is : equal to : ="abc"
Format... : Patterns : pink colorindex 38

Sub test()
Dim cnt As Long, i As Long
Dim rng As Range
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Set wsSource = Worksheets("Sheet1")
Set wsDest = Worksheets("Sheet2")

wsSource.Cells.Copy
wsDest.Cells.PasteSpecial xlValues
wsDest.Cells.PasteSpecial xlFormats

On Error Resume Next
Set rng = wsSource.Cells(1,
1).SpecialCells(xlCellTypeAllFormatConditions)
On Error GoTo 0

If Not rng Is Nothing Then
wsDest.Cells.FormatConditions.Delete
ReDim arrCFs(1 To rng.Count) As String

For Each cell In rng
If cell.Value = "abc" Then
cnt = cnt + 1
arrCFs(cnt) = cell.Address
End If
Next

With wsDest
For i = 1 To cnt
.Range(arrCFs(i)).Interior.ColorIndex = 38
Next
End With

End If
wsDest.Activate
Range("A1").Select

End Sub

I can't imagine ever using code as written above, it's only an illustration.

Your second question -

I adapted the following code from Peter T to my sub, but the pictures all
pasted starting in cell A1 for some reason.

The routine appears to have been copied exactly from another post and not
"adapted", at least as far as I can see. Have you changed something in your
own project perhaps. If not, I don't know why your pictures are pasted to
cell A1, try and recreate manually what the code attempts to do -

- Select the objects you want to copy (in your case all pictures)
- Visually note the topmost row of any selected object and the left most
column of any selected object, scroll right & down if necessary, say B4 is
the top left intersect
- Right click selected objects and Copy
- Activate the destination sheet
- Select cell B4 as the potential topleft cell of all objects
- Paste

Does this paste objects into correct relative positions, if so I'm not sure
why the macro doesn't work same.

Regards,
Peter T

 

[justme]

Hi Peter!

Thank you thank you thank you for all your help! As for the picture
problem, I HAD originally adapted it for my own workbook, but when I couldn't
get it working, I deleted it, so I just copied your original posted code into
my question.

So, I followed your picture "manual test" and after that, magically the code
worked when i ran it again. But later on, my sub was doing the same thing
with the pictures, pasting pics starting from cell A1. I don't know what is
wrong with my code, but I seem to have stabilized it for now by replacing.

with

I don't know, why, but it's working for now. Thanks so much!!

If you feel like it, you can peruse my code below and maybe see what may be
wrong with it. I am really not a programming, just painstakingly patching
stuff together one by one...



Public Sub WT_CreateForms()
'
' Creates individual fitter sheets with fitter-specific data from master
fitter sheet and renames all sheets

On Error GoTo ErrorHandler

'General
Dim MFS As Worksheet
Dim FST As Worksheet
Dim FTRS As Worksheet
Dim WTSS As Worksheet
Dim CFS As Worksheet 'Current Fitter Sheet

Set MFS = ActiveWorkbook.Sheets("MasterFitterSurvey")
Set FST = ActiveWorkbook.Sheets("fsTemplate")
Set FTRS = ActiveWorkbook.Sheets("Fitters")
Set WTSS = ActiveWorkbook.Sheets("WearTestSurveySheet")

'Fitters
Dim iRow As Long
Dim myRange As Range, Cell As Range

'Sheet Naming
Dim myDate As String
Dim myStyle As String
Dim myFitter As String
Dim SheetName As String
Dim TestType As String

TestType = MFS.Cells(10, 17).Text
myStyle = MFS.Cells(5, 4).Text

'Input Date For Sheet Names
Do While myDate = vbNullString
myDate = Application.InputBox(Prompt:="Please Enter Today's Date as YYMMDD",
Type:=2, Default:=Format(Date, "yymmdd"))
If myDate = vbNullString Then
MsgBox ("You must enter a Date as YYMMDD or Cancel; please try again")
End If
Loop
If myDate = "False" Then 'user pressed cancel
FTRS.Select
Exit Sub
End If


'START LOOP
'Move First Fitter Into Position
FTRS.Activate
For iRow = 6 To FTRS.Cells(FTRS.Rows.Count, "A").End(xlUp).Row
FTRS.Range("A" & iRow, "AH" & iRow).Select
Selection.RowHeight = 13
Selection.Copy

FTRS.Range("A3", "AH3").Select
ActiveSheet.Paste
Selection.RowHeight = 13






'CREATE NEW FITTER SHEETS
'Copy FST fitter template containing change event code

myFitter = Left(FTRS.Cells(3, 3).Text, 6) & Left(FTRS.Cells(3, 4).Text, 1)
FST.Copy After:=Sheets(ActiveWorkbook.Sheets.Count)
SheetName = myDate & "_" & myStyle & "_" & TestType & "_FSH_" & myFitter
Sheets(ActiveWorkbook.Sheets.Count).Name = SheetName
Set CFS = ActiveSheet

'Copy MFS Information to New Worksheet
MFS.Activate
With MFS
Cells.Select
Selection.Copy
End With

'Paste MFS Information to New Worksheet
CFS.Activate
With CFS.Range("A1")
..PasteSpecial xlPasteValuesAndNumberFormats
..PasteSpecial xlFormats
..PasteSpecial xlPasteValidation
..PasteSpecial xlPasteComments
End With


'Format unfillled fitter info to turn green when filled in
With CFS
Set myRange = .Range(.Cells(15, "E"), .Cells(16, "E")) '''Variable cell
Reference
For Each Cell In myRange
If Cell.Value Like "Please*" Then
Cell.Font.ColorIndex = 4
Cell.Font.Italic = False
End If
Next Cell
End With
With CFS
Set myRange = .Range(.Cells(20, "K"), .Cells(22, "K")) '''Variable Cell
Reference
For Each Cell In myRange
If Cell.Value Like "Please*" Then
Cell.Font.ColorIndex = 4
Cell.Font.Italic = False
End If
Next Cell
End With

'Edit Filled-in Fitter info cells in E15 and E16 & K20-k22 to induce
worksheet change event merged cell autofit sub
With CFS
Set myRange = .Range(.Cells(15, "E"), .Cells(16, "E")) '''Variable cell
Reference
For Each Cell In myRange
If Not Cell.Value Like "Please*" Then
Cell.Value = Cell & ".."
Cell.Value = Left(Cell.Value, Len(Cell.Value) - 2)
End If
Next Cell
End With
With CFS
Set myRange = .Range(.Cells(20, "K"), .Cells(22, "K")) '''Variable Cell
Reference
For Each Cell In myRange
If Not Cell.Value Like "Please*" Then
Cell.Value = Cell & ".."
Cell.Value = Left(Cell.Value, Len(Cell.Value) - 2)
End If
Next Cell
End With

'MFS.Activate
'Range("A1").Select
'CFS.Activate
'Range("A1").Select


'Copy all pictures to new Fitter Sheet
MFS.Activate

Dim r As Long, c As Long
Dim pic As Picture

r = MFS.Rows.Count
c = MFS.Columns.Count

For Each pic In MFS.Pictures
With pic.TopLeftCell
If .Row < r Then r = .Row
If .Column < c Then c = .Column
End With
Next

CFS.Activate
CFS.Cells(r, c).Activate

MFS.Pictures.Copy
CFS.Cells(r, c).Select
CFS.Paste

CFS.Cells(1, 1).Activate
Set CFS = Nothing

FTRS.Activate
Next iRow


'RENAME FTRS
FTRS.Select
SheetName = myDate & "_" & myStyle & "_" & TestType & "_FTRS"
FTRS.Name = SheetName

'RENAME MFS
MFS.Select
SheetName = myDate & "_" & myStyle & "_" & TestType & "_MFS"
MFS.Name = SheetName

'RENAME WTSS
WTSS.Select
SheetName = myDate & "_" & myStyle & "_" & TestType & "_SS"
WTSS.Name = SheetName

'Save Workbook
ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\Marib\My
Documents\0- Wear Testing\Projects\" & SheetName & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False, CreateBackup:=False

SheetName = ""

ErrorHandlerNext:
Exit Sub

ErrorHandler:
'Err.Raise 1001
MsgBox "Error " & Err.Number & "; " & Err.Description
'Resume ErrorHandlerNext

End Sub

 

[Peter T]

Glad you got it working

You say you need to include "wsDest.Cells(r, c).Select"

I assume ? you've also kept these original lines just a little earlier in
the code -

wsDest.Activate
wsDest.Cells(r, c).Activate

Not sure why the new line helps, seems to duplicate what's already done, but
if it does keep it!

you can peruse my code below and maybe see what may be
wrong with it.

I can't test without recreating your workbook, which I can't, and would take
a long time to see what's wrong - you haven't given a clue as to why you
think it is wrong.
However you've got a lot going on there and would strongly recommend you
break it down in to a number of Subs or Functions, passing variables between
them as necessary. You may then find it much easier to debug yourself. Set a
few break points, look at what's going on, query any variables by ? in the
immediate window or by setting Watches.

Regards,
Peter T

 

[justme]

Thank you Peter!