Is this possible? Copy Cells with different text colours?

[ClimoC]

'Ello...

Situation:

2 sheets with tables of info, variable text lengths in each cell. Each 'line' in each cell is separated with carriage returns (crlf's/chr(10)'s).

My script compares the first 4 characters after each crLf with the corresponding characters in the other sheet. If they are different, it highlights just those four characters. Ditto for the other part of the separated-string.

ie, you get results that look like this:

Cell1: "1000} Go to Doctor"

Cell2: "1100} Go to Doctor"

-Would make just "1100" red because it has changed.

Example2:
Cell1: "1000} Go to Doctor"
Cells2: "1000} Go to Dentist"

-Would make "Go to Dentist" red because it has changed.


This all works really well, but then what I'm trying to do, in the quickest code possible, is transfer this information to other workbooks/tables.

Doing a GUI Copy-Paste works, but my code for transferring the data does match/lookups in vba, and then uses the ".value = Cells(xrow,ycol).value", so the text colours get lost.

Anyone know a way of doing this? I really don't want to find the destination cell and then put my sheets through the labour of 5000 "Copy, PastexlAll, CutCopymode=False" 's because the procedure already takes 15 seconds as it is!

 

[Ruddles]

...the ".value = Cells(xrow,ycol).value", so the text colours get lost.

You could follow it up with a quick ".Font.Color = Cells(xrow,ycol).Font.Color" - yes?

 

[ClimoC]

You could follow it up with a quick ".Font.Color = Cells(xrow,ycol).Font.Color" - yes?

Sadly no. You'd think so, but the Font.Color (and Font.Colorindex) property is set at Null (apparently!)

It would be nice to know where and how it stores the font color property of certain string parts. It must 'know', because as I said, straight GUI Copy and Paste matches the varying colour properties of the string splits.

 

[RoryA]

You'd be better off copying I think, but do it in one line:

.Copy Destination:=Cells(x, y)

 

[ClimoC]

Seems late-in-the-piece to be mentioning it, but it actually converts the table from one sheet to a second, and then transposes that info in the second sheet again to a third sheet, to allow users to run reports and then view them in multiple formats with Time,Day, and Type all as various X/Y axis combinations.

Here's the two pertinent pieces of code at the moment:

Dim DataS As String, DataD As String
Dim Mast1 As Worksheet, Mast2 As Worksheet
Dim xS As Integer, yS As Integer, xD As Integer, yD As Integer
StatusBar.Label4 = "Generating Alternative Formats...(By Days)..."
StatusBar.Repaint
Set Mast1 = OutPut.Sheets("By Type")
Set Mast2 = OutPut.Sheets("By Days")
For Each ppr In Mast1.Range("A1:A" & Mast1.Range("A65000").End(xlUp).Row)
        If Not ppr.Value = "" Then
                        DataS = Mast1.Range(Mast1.Range("A1:A" & Mast1.Range("A65000").End(xlUp).Row).Find(what:=ppr.Value, _
                                                                            LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True).Offset(2, 3).Address).Address
'Application.Visible = True
                        DataD = Mast2.Range(Mast2.Range("C1:C" & Mast2.Range("A65000").End(xlUp).Row).Find(what:=ppr.Value, _
                                                                            LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True).Offset(0, 1).Address).Address
                                Debug.Print DataS
                                Debug.Print DataD
                                xS = 0
                                yS = 0
                                xD = 0
                                yD = 0
                    For xD = 0 To 116 Step 16
                                yD = 0
                                For xS = 0 To 6 Step 1
                                        Mast2.Range(DataD).Offset(xD, yD).Value = Mast1.Range(DataS).Offset(xS, yS).Value
                                    yD = yD + 1
                                Next xS
                        yS = yS + 1
                    Next xD
        End If
Next

Essentially, I'm doing some tricky Transposing, between grids that can could be anywhere on the two different sheets.

The second part, is similar, but I am able to do with a simple Copy/Paste with Transpose and skipblanks.

Dim SR As Integer, DR As Integer, CR As Range

'17:00
For SR = 4 To 17 Step 1
'Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic
DR = OutPut.Sheets("By TimeSlots").Range("C4:C17").Find(what:=OutPut.Sheets("By Days").Range("C" & SR).Value, LookIn:=xlValues, _
                                                                                                    lookat:=xlWhole, MatchCase:=True).Row

Set CR = _
                    Union(OutPut.Sheets("By Days").Range("D" & SR), OutPut.Sheets("By Days").Range("D" & SR + 16), _
                    OutPut.Sheets("By Days").Range("D" & SR + 32), OutPut.Sheets("By Days").Range("D" & SR + 48), _
                    OutPut.Sheets("By Days").Range("D" & SR + 64), OutPut.Sheets("By Days").Range("D" & SR + 80), _
                    OutPut.Sheets("By Days").Range("D" & SR + 96))

With OutPut.Sheets("By Days")
                CR.Copy
    OutPut.Sheets("By TimeSlots").Range("D" & DR).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        True, Transpose:=True
End With
Next SR

All of the above works flawlessly, and handles many different things users could do wrong within the context of the App.

The 'xlPasteAll' in the second piece of code will (I'm pretty sure) work, if I can amend the first code to correctly bring the different text strings' colours across from the first sheet (source data), called "By Type"


So...

Do I just need to change "Mast2.Range(DataD).Offset(xD, yD).Value = Mast1.Range(DataS).Offset(xS, yS).Value" for a "Cells(x,y).offset(xx,yy).copy Destination Cells(x2,y2).offset(xx2,yy2)" type argument instead?

 

[Ruddles]

...it highlights just those four characters.

Sorry, mea culpa - I didn't spot that the first time round.

Umm... try:-

[I]newcell[/I].Characters(1, 4).Font.ColorIndex = [I]oldcell[/I].Characters(1, 4).Font.ColorIndex

(Tested & working here.)

 

[ClimoC]

Sorry, mea culpa - I didn't spot that the first time round.

Umm... try:-

[I]newcell[/I].Characters(1, 4).Font.ColorIndex = [I]oldcell[/I].Characters(1, 4).Font.ColorIndex

(Tested & working here.)

Well I clearly did think of that... (sorry to sound prissy)... but the thing is that there are anywhere between 1 and 4 'lines' separated by the CrLf's in each cell, and each line is treated on its own when it comes to the string-compare function I wrote. So I can't just do a straight "Left(myCell,4).font.colorindex = 3", because then I have to initiate ANOTHER loop through the strings inbetween each carriage return to determine whether or not they are red or black fonts.

My function for it is as follows: (so you get an idea of what I have to do to GET it to the point I have now, with the copying problem)

Dim x1 As String, y1 As String
Dim x1CRs As Integer, x2CRs As Integer
Dim x1CRCOUNT As Integer, xCRPOS As Integer, xCRPOS2 As Integer, yCRPOS As Integer, yCRPOS2 As Integer
Dim YisBigger As Boolean
'make ranges strings
x1 = CStr(x.Value)
y1 = CStr(y.Value)

YisBigger = False
'count the number of Carriage returns in each string to set the number of iterative loops
x1CRs = Len(x1) - Len(Replace(x1, Chr(10), ""))
x2CRs = Len(y1) - Len(Replace(y1, Chr(10), ""))

If x2CRs > x1CRs Then YisBigger = True

Debug.Print x1
Debug.Print y1
On Error Resume Next

If Not x1CRs = 0 And Not x2CRs = 0 Then 'if there are CR's in both strings
For x1CRCOUNT = 0 To (x1CRs - 1) Step 1 'increment through each string section, as separated by the CR's
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    If x1CRCOUNT = 0 Then
        If Left(x1, 4) <> Left(y1, 4) Then y.Characters(1, 4).Font.ColorIndex = 3
                Debug.Print ClimoPCT(strcleanse(Mid(x1, 6, InStr(6, x1, Chr(10), vbTextCompare) - 6)), strcleanse(Mid(y1, 6, InStr(6, y1, Chr(10), vbTextCompare) - 6)), 2, False)
                If ClimoPCT(strcleanse(Mid(x1, 6, InStr(6, x1, Chr(10), vbTextCompare) - 6)), strcleanse(Mid(y1, 6, InStr(6, y1, Chr(10), vbTextCompare) - 6)), 2, False) < 0.75 Then
                        If Mid(x1, 6, InStr(6, x1, Chr(10), vbTextCompare) - 6) <> Mid(y1, 6, InStr(6, y1, Chr(10), vbTextCompare) - 6) Then y.Characters(Start:=6, Length:=InStr(1, y1, Chr(10), vbTextCompare) - 6).Font.ColorIndex = 3
                End If
                
            xCRPOS = InStr(1, x1, Chr(10), vbTextCompare)
            yCRPOS = InStr(1, y1, Chr(10), vbTextCompare)
    Else
        xCRPOS2 = InStr(xCRPOS + 1, x1, Chr(10), vbTextCompare)
        yCRPOS2 = InStr(yCRPOS + 1, y1, Chr(10), vbTextCompare)

        
        If Mid(x1, xCRPOS + 1, 4) <> Mid(y1, yCRPOS + 1, 4) Then y.Characters(Start:=yCRPOS + 1, Length:=4).Font.ColorIndex = 3
        Debug.Print ClimoPCT(strcleanse(Mid(x1, xCRPOS + 6, (xCRPOS2 - xCRPOS) - 6)), strcleanse(Mid(y1, yCRPOS + 6, (yCRPOS2 - yCRPOS) - 6)), 2, False)
        If ClimoPCT(strcleanse(Mid(x1, xCRPOS + 6, (xCRPOS2 - xCRPOS) - 6)), strcleanse(Mid(y1, yCRPOS + 6, (yCRPOS2 - yCRPOS) - 6)), 2, False) < 0.75 Then
                If Mid(x1, xCRPOS + 6, (xCRPOS2 - xCRPOS) - 6) <> Mid(y1, yCRPOS + 6, (yCRPOS2 - yCRPOS) - 6) Then y.Characters(Start:=yCRPOS + 6, Length:=(yCRPOS2 - yCRPOS) - 6).Font.ColorIndex = 3
        End If
    End If
    
        If x1CRCOUNT <> 0 Then
            xCRPOS = xCRPOS2
            yCRPOS = yCRPOS2
        End If
Next x1CRCOUNT

If YisBigger = True Then
        'y.Characters(yCRPOS2 + 1, yCRPOS2 - (Len(y1) - (yCRPOS2 - 1))).Font.ColorIndex = 3
        y.Font.ColorIndex = 3
End If

End If

On Error GoTo 0

NB: 'StrCleanse' is simple String Cleanser, to remove spaces, periods, commas etc

'ClimoPCT' is a string-percentage match, which is just a modification of the 'FuzzyLookup' that you could google for if you tried (written by a very clever cookie I have mentioned somewhere in my own code) - but that's irrelevant. It's about what goes on in between each CrLf that matters, and that's what I compare for deciding whether or not to change the font colour.

 

[RoryA]

Do I just need to change "Mast2.Range(DataD).Offset(xD, yD).Value = Mast1.Range(DataS).Offset(xS, yS).Value" for a "Cells(x,y).offset(xx,yy).copy Destination Cells(x2,y2).offset(xx2,yy2)" type argument instead?

It would appear so.

 

[ClimoC]

Ok I'll give it a go, thanks guys.

I just hope it isn't horrifically slow (comparably..)!

 

[ClimoC]

Success!!! Thanks for helping me nut that out guys