Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy current color of conditional formatted cell
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy current color of conditional formatted cell
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" wrote in message ... 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy current color of conditional formatted cell
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. wsSource.Pictures.Copy wsDest.Paste with wsSource.Pictures.Copy wsDest.Cells(r, c).Select wsDest.Paste 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy current color of conditional formatted cell
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" wrote in message ... 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. wsSource.Pictures.Copy wsDest.Paste with wsSource.Pictures.Copy wsDest.Cells(r, c).Select wsDest.Paste 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy current color of conditional formatted cell
Thank you Peter!
:) |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Change tab color based on current color of a cell | Excel Discussion (Misc queries) | |||
Conditional Formatted numbers add based on color? | Excel Programming | |||
sum by conditional formatted color | Excel Discussion (Misc queries) | |||
Conditional Formatted Cell Color Index | Excel Programming | |||
cell formatted for current day | Excel Programming |