Preserve all formatting

U

UnitedCloud01

New Member
Joined
Nov 14, 2017
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Hi All :)

I have a cell (Y6) that returns a value:

Code: 
IF($K6="","",IF($K6>=61,DATA!$A$91,IF($K6>=51,DATA!$A$90,IF($K6>=1,DATA!$A$89,""))))

I have formatted the results in DATA!$A as I would like it to appear in the working sheet.:

[TABLE="width: 511"]
<colgroup><col width="682" style="width: 511pt; mso-width-source: userset; mso-width-alt: 24234;"> <tbody>[TR]
[TD="class: xl67, width: 682, bgcolor: red"]RED GROUPS & WORKERS:
- Severe emotional /behavioural dysregulation
- Severe distress intolerance and mood disturbance
- Brain area: Brainstem/Diencephalon
- CGAF ≤ 50[/TD]
[/TR]
[TR]
[TD="class: xl69, width: 682, bgcolor: #FFC000"]AMBER GROUPS & WORKERS:
- Moderate emotional/ behavioural dysregulation
- Moderate mood disturbance
- Brain area: Limbic
- CGAF 50-60[/TD]
[/TR]
[TR]
[TD="class: xl68, width: 682, bgcolor: #92D050"]GREEN GROUPS & WORKERS:
- Mild emotional/ behavioural dysregulation
- Mild mood disturbance
- Brain area: Prefrontal Cortex
- CGAS 60-75[/TD]
[/TR]
</tbody>[/TABLE]

I have tried the following VBA:

Code: 
[FONT=Calibri][SIZE=3][COLOR=#000000]Range("Y6").Value = Range("[SIZE=2][COLOR=#222222]DATA!$A$91[/COLOR][/SIZE]").Value<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][FONT=Calibri][SIZE=3][COLOR=#000000]For i = 1 To Range("[SIZE=2][COLOR=#222222]DATA!$A$91[/COLOR][/SIZE]").Characters.Count<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][FONT=Calibri][SIZE=3][COLOR=#000000]   Range("Y6").Characters(i, 1).Font.Bold =Range("[SIZE=2][COLOR=#222222]DATA!$A$91[/COLOR][/SIZE]").Characters(i, 1).Font.Bold<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][FONT=Calibri][SIZE=3][COLOR=#000000]   Range("Y6").Characters(i, 1).Font.Color =Range("[SIZE=2][COLOR=#222222]DATA!$A$91[/COLOR][/SIZE]").Characters(i, 1).Font.Color<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][FONT=Calibri][SIZE=3][COLOR=#000000]   [/COLOR][/SIZE][/FONT][FONT=Calibri][SIZE=3][COLOR=#000000]Range("Y6").Characters(i, 1).Font.FontStyle = Range("[SIZE=2][COLOR=#222222]DATA!$A$91[/COLOR][/SIZE]").Characters(i,1).Font.FontStyle<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][FONT=Calibri][SIZE=3][COLOR=#000000]   Range("Y6").Interior.ColorIndex =Range("[SIZE=2][COLOR=#222222]DATA!$A$91[/COLOR][/SIZE]").Interior.ColorIndex<o:p></o:p>[/COLOR][/SIZE][/FONT]


This code does indeed preserve the formatting, in this instance from DATA!$A$91 but I cannot work out how to alter the code to reflect the change in the result in cell "Y6".

This code needs to work for all active cells in column "Y".

I look forward to your assistance.

Regards

Scott
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
If the values in col K are being entered manually try this.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

Application.EnableEvents = False

    If Target.Column <> 11 Or Target.CountLarge > 1 Then Exit Sub
    Select Case Target
        Case Is <= 50
            Sheets("Data").Range("A89").Copy Range("Y" & Target.Row)
        Case 51 To 60
            Sheets("Data").Range("A90").Copy Range("Y" & Target.Row)
        Case Is >= 61
            Sheets("Data").Range("A91").Copy Range("Y" & Target.Row)
    End Select

Application.EnableEvents = True

End Sub
It needs to go in the sheet module, where you want the info to appear.
 
Last edited:
Upvote 0
Hi Fluff

Thanks so much for the reply. :) :)

I have tried it but nothing seems to happen.

K was originally a number chosen by a pull down list but I removed this and still nothing.

The Target column Y is a merged cell so I unmerged and still nothing. Y values commence from row 6 too.

Thank you so much for taking the time to reply.

Hope you can still assist.

Regards

Scott :)
 
Upvote 0
To check that you have put the code in the right place, right click on the working tab (not the data tab) & select view code. Is the code I supplied there?
If so add the word stop like this
Code: 
Application.EnableEvents = False
Stop
    If Target.Column <> 11 Or Target.CountLarge > 1 Then Exit Sub
Then change the value in K6 & the code window should open up with the word stop highlighted. Does that happen?
 
Upvote 0
Hi Again

The Code is sitting on the working tab.

I added Stop but nothing.

It also makes my other VBA stop:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    Dim xUsed1 As Long
    Dim strVal As String
    Dim i As Long
    Dim lCount As Long
    Dim Ar As Variant
    On Error Resume Next
    Dim lType As Long
    If Target.Count > 1 Then GoTo exitHandler
    
    On Error Resume Next
    Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    If Not Application.Intersect(Target, xRng) Is Nothing Then
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 = "" Then
            'do nothing
        Else
            If xValue2 = "" Then
                'do nothing
            Else
                On Error Resume Next
                Ar = Split(xValue1, ", ")
                strVal = ""
                For i = LBound(Ar) To UBound(Ar)
                    Debug.Print strVal
                    Debug.Print CStr(Ar(i))
                    If xValue2 = CStr(Ar(i)) Then
                        'do not include this item
                        strVal = strVal
                        lCount = 1
                    Else
                        strVal = strVal & CStr(Ar(i)) & ", "
                    End If
                Next i
                If lCount > 0 Then
                    Target.Value = Left(strVal, Len(strVal) - 2)
                Else
                    Target.Value = strVal & xValue2
                End If
            End If
        End If
    End If
exitHandler:
  Application.EnableEvents = True
End Sub
 
Upvote 0
You can only have one worksheet_change event per sheet, which is why they aren't working.
With the code you have just supplied is that working on a specific column, if so which?
 
Upvote 0
Hi there

The Supplied Code works on any cell that has a pull down list and allows for multiple selections.

I have combined code previously that worked e.g.,:

Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'   First check
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    Dim xUsed1 As Long
    Dim strVal As String
    Dim i As Long
    Dim lCount As Long
    Dim Ar As Variant
    On Error Resume Next
    Dim lType As Long
    If Target.Count > 1 Then GoTo exitHandler
    On Error Resume Next
    Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If Not Application.Intersect(Target, xRng) Is Nothing Then
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 = "" Then
            'do nothing
        Else
            If xValue2 = "" Then
                'do nothing
            Else
                On Error Resume Next
                Ar = Split(xValue1, ", ")
                strVal = ""
                For i = LBound(Ar) To UBound(Ar)
                    Debug.Print strVal
                    Debug.Print CStr(Ar(i))
                    If xValue2 = CStr(Ar(i)) Then
                        'do not include this item
                        strVal = strVal
                        lCount = 1
                    Else
                        strVal = strVal & CStr(Ar(i)) & ", "
                    End If
                Next i
                If lCount > 0 Then
                    Target.Value = Left(strVal, Len(strVal) - 2)
                Else
                    Target.Value = strVal & xValue2
                End If
            End If
        End If
    End If
    
'   Second check
    Range("d1009").Value = ColorFunction(Range("a1009"), Range("n8:n1007"))
    Range("d1010").Value = ColorFunction(Range("a1010"), Range("u8:u1007"))
    Range("d1011").Value = ColorFunction(Range("a1011"), Range("bl8:bl1007"))
    Range("d1012").Value = ColorFunction(Range("a1012"), Range("au8:au1007"))
    Range("d1013").Value = ColorFunction(Range("a1013"), Range("bm8:bm1007"))
    Range("d1014").Value = ColorFunction(Range("a1014"), Range("c8:c1007"))
    Range("d1015").Value = ColorFunction(Range("a1015"), Range("a8:a1007"))
           
exitHandler:
Application.EnableEvents = True
End Sub

Thank you for continuing to help me.

Thanks

Scott
 
Upvote 0
Ooohh...btw...I did delete the existing code and just had yours but it still wouldn't work. :(
 
Upvote 0
Afetr removing your existing code, did you try mine with the stop line in?
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Combine text from different cells but apply different formatting
Replies
1
Views
1K
attikuz
A
Jambi46n2
  • Question Question
VBA Nested Loop Help!
Replies
1
Views
380
Jambi46n2
Jambi46n2
M
  • Question Question
Complicated transpose of data with conditions
Replies
3
Views
1K
mahmed1
M
C
  • Question Question
Convert TEXT back to TEXT after this code converts it to unwanted DATE format??
Replies
1
Views
618
Jonmo1
Jonmo1

Forum statistics

Threads
1,223,894
Messages
6,175,254
Members
452,624
Latest member
gregg777

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top