| Home |
| Search |
| Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
copy and paste problem
I have created a work sheet which using the workbook change subroutine
changes the background colour of cells and edits the content if certain letters or number are added. This works ok until I copy and paste into this range and then the background changes from the selected colour to pink for all the pasted cells I need to replicate in the range certain blocks of data and dont want to have to type it in each time is there any way I can keep the copied cells format as I paste them into the automated range. Private Sub Worksheet_Change(ByVal Target As Excel.Range) On Error Resume Next 'Sets the range of cells for the code to work if a cell other than the range is altered 'the sub is exited. Set Target = Intersect(Target, Range("B21:h21", "b700:h700")) If Target Is Nothing Then Exit Sub 'If the cells in the range equal this criteria then they are changed accordingly 'Weekly Rest Day ElseIf Target = "RD" Then With Target .Interior.ColorIndex = 17 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Annual Leave ElseIf Target = "AL" Then With Target .Interior.ColorIndex = 4 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Bank Holiday Leave ElseIf Target = "BH" Then With Target .Interior.ColorIndex = 24 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Duty Elsewhere ElseIf Target = "DE" Then With Target .Interior.ColorIndex = 15 .Font.ColorIndex = 11 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Football ElseIf Target = "FB" Then With Target .Interior.ColorIndex = 27 .Font.ColorIndex = 25 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Lieu Leave ElseIf Target = "LL" Then With Target .Interior.ColorIndex = 33 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'CADRE cover ElseIf Target = "n" Then Target = UCase(Target) With Target .Interior.ColorIndex = 22 .Font.ColorIndex = 6 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'CADRE cover ElseIf Target = "c" Then Target = UCase(Target) With Target .Interior.ColorIndex = 22 .Font.ColorIndex = 2 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'CADRE cover ElseIf Target = "e" Then Target = UCase(Target) With Target .Interior.ColorIndex = 22 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'PACE cover ElseIf Target = "x" Then Target = UCase(Target) With Target .Interior.ColorIndex = 3 .Font.ColorIndex = 2 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Weekly Rest Day ElseIf Target = "rd" Then Target = UCase(Target) With Target .Interior.ColorIndex = 17 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Annual Leave ElseIf Target = "al" Then Target = UCase(Target) With Target .Interior.ColorIndex = 4 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Bank Holiday Leave ElseIf Target = "bh" Then Target = UCase(Target) With Target .Interior.ColorIndex = 24 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Paternity Leave ElseIf Target = "pl" Then Target = UCase(Target) With Target .Interior.ColorIndex = 7 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Duty Elsewhere ElseIf Target = "de" Then Target = UCase(Target) With Target .Interior.ColorIndex = 15 .Font.ColorIndex = 11 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Football ElseIf Target = "fb" Then Target = UCase(Target) With Target .Interior.ColorIndex = 27 .Font.ColorIndex = 25 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Lieu Leave ElseIf Target = "ll" Then Target = UCase(Target) With Target .Interior.ColorIndex = 33 .Font.ColorIndex = 1 .Font.Bold = True End With ElseIf Target = "8" Then Target = "8x5" With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = False End With ElseIf Target = "10" Then Target = "10x7" With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = False End With ElseIf Target = "12" Then Target = "12x9" With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = False End With ElseIf Target = "1" Then Target = "1x9" With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = False End With 'If the cells in the range equal this criteria then they are changed accordingly 'Empty Cells ElseIf Target = "" Then With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = True End With 'If anything other than this criteria is entered then the cells are left unformatted. End If End Sub Here is the code I am currently using |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
copy and paste problem
Here is a better way of writting your code. I converted the first few ifelse
sections to demonstrate how to use the Case Select Private Sub Worksheet_Change(ByVal Target As Excel.Range) On Error Resume Next 'Sets the range of cells for the code to work if a cell other than the range 'is altered 'the sub is exited. Set Target = Intersect(Target, Range("B21:h21", "b700:h700")) If Target Is Nothing Then Exit Sub 'If the cells in the range equal this criteria 'then they are changed accordingly 'Weekly Rest Day With Target Select Case Target Case Target = "RD" .Interior.ColorIndex = 17 .Font.ColorIndex = 1 .Font.Bold = True Case Target = "AL" 'If the cells in the range equal this 'criteria then they are changed accordingly 'Annual Leave .Interior.ColorIndex = 4 .Font.ColorIndex = 1 .Font.Bold = True 'If the cells in the range equal this criteria ' then they are changed accordingly 'Bank Holiday Leave Case Target = "BL" .Interior.ColorIndex = 24 .Font.ColorIndex = 1 .Font.Bold = True 'If the cells in the range equal this _ ' criteria then they are changed accordingly 'Duty Elsewhere Case Target = "DE" .Interior.ColorIndex = 15 .Font.ColorIndex = 11 .Font.Bold = True End Select End With End If End Sub "Fred Kruger" wrote: I have created a work sheet which using the workbook change subroutine changes the background colour of cells and edits the content if certain letters or number are added. This works ok until I copy and paste into this range and then the background changes from the selected colour to pink for all the pasted cells I need to replicate in the range certain blocks of data and dont want to have to type it in each time is there any way I can keep the copied cells format as I paste them into the automated range. Private Sub Worksheet_Change(ByVal Target As Excel.Range) On Error Resume Next 'Sets the range of cells for the code to work if a cell other than the range is altered 'the sub is exited. Set Target = Intersect(Target, Range("B21:h21", "b700:h700")) If Target Is Nothing Then Exit Sub 'If the cells in the range equal this criteria then they are changed accordingly 'Weekly Rest Day ElseIf Target = "RD" Then With Target .Interior.ColorIndex = 17 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Annual Leave ElseIf Target = "AL" Then With Target .Interior.ColorIndex = 4 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Bank Holiday Leave ElseIf Target = "BH" Then With Target .Interior.ColorIndex = 24 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Duty Elsewhere ElseIf Target = "DE" Then With Target .Interior.ColorIndex = 15 .Font.ColorIndex = 11 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Football ElseIf Target = "FB" Then With Target .Interior.ColorIndex = 27 .Font.ColorIndex = 25 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Lieu Leave ElseIf Target = "LL" Then With Target .Interior.ColorIndex = 33 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'CADRE cover ElseIf Target = "n" Then Target = UCase(Target) With Target .Interior.ColorIndex = 22 .Font.ColorIndex = 6 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'CADRE cover ElseIf Target = "c" Then Target = UCase(Target) With Target .Interior.ColorIndex = 22 .Font.ColorIndex = 2 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'CADRE cover ElseIf Target = "e" Then Target = UCase(Target) With Target .Interior.ColorIndex = 22 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'PACE cover ElseIf Target = "x" Then Target = UCase(Target) With Target .Interior.ColorIndex = 3 .Font.ColorIndex = 2 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Weekly Rest Day ElseIf Target = "rd" Then Target = UCase(Target) With Target .Interior.ColorIndex = 17 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Annual Leave ElseIf Target = "al" Then Target = UCase(Target) With Target .Interior.ColorIndex = 4 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Bank Holiday Leave ElseIf Target = "bh" Then Target = UCase(Target) With Target .Interior.ColorIndex = 24 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Paternity Leave ElseIf Target = "pl" Then Target = UCase(Target) With Target .Interior.ColorIndex = 7 .Font.ColorIndex = 1 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Duty Elsewhere ElseIf Target = "de" Then Target = UCase(Target) With Target .Interior.ColorIndex = 15 .Font.ColorIndex = 11 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Football ElseIf Target = "fb" Then Target = UCase(Target) With Target .Interior.ColorIndex = 27 .Font.ColorIndex = 25 .Font.Bold = True End With 'If the cells in the range equal this criteria then they are changed accordingly 'Lieu Leave ElseIf Target = "ll" Then Target = UCase(Target) With Target .Interior.ColorIndex = 33 .Font.ColorIndex = 1 .Font.Bold = True End With ElseIf Target = "8" Then Target = "8x5" With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = False End With ElseIf Target = "10" Then Target = "10x7" With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = False End With ElseIf Target = "12" Then Target = "12x9" With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = False End With ElseIf Target = "1" Then Target = "1x9" With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = False End With 'If the cells in the range equal this criteria then they are changed accordingly 'Empty Cells ElseIf Target = "" Then With Target .Interior.ColorIndex = 2 .Font.ColorIndex = 1 .Font.Bold = True End With 'If anything other than this criteria is entered then the cells are left unformatted. End If End Sub Here is the code I am currently using |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Copy and paste problem | Excel Discussion (Misc queries) | |||
| Copy/Paste problem | Excel Programming | |||
| Excel cut/Paste Problem: Year changes after data is copy and paste | Excel Discussion (Misc queries) | |||
| Copy/Paste Problem | Excel Programming | |||
| Copy/Paste Problem | Excel Programming | |||
![Fred Kruger[_2_] is offline](https://www.excelbanter.com/images/SultanThemeVB3R/statusicon/user_offline.gif)
Linear Mode
