troubleshooting Question

Run-Time error "13" type mismatch - problem with code and txt/number

Avatar of jamiepryer
jamiepryerFlag for United Kingdom of Great Britain and Northern Ireland asked on
VB Script
12 Comments1 Solution600 ViewsLast Modified:
Hi,
im using the following code i found on the web and it all works fine when im converting numbers.
However when i try and use this against some txt, it falls over?
any suggestions on what needs to be changed?

nb. this code is for changing conditional formatting to its "real" value.
Option Explicit
Sub PasteFC()
    
    Dim rWhole As Range
    Dim rCell As Range
    Dim ndx As Integer
    Dim FCFont As Font
    Dim FCBorder As Border
    Dim FCInt As Interior
    Dim x As Integer
'    Dim iBorders(3) As Integer
'
'    iBorders(0) = xlLeft
'    iBorders(1) = xlRight
'    iBorders(2) = xlTop
'    iBorders(3) = xlBottom
    
    GetRange2
    Application.ScreenUpdating = False
    Set rWhole = Selection
 
    For Each rCell In rWhole
        rCell.Select
        ndx = ActiveCondition(rCell)
        If ndx <> 0 Then
            'Change the Font info
            Set FCFont = rCell.FormatConditions(ndx).Font
            With rCell.Font
                .Bold = NewFC(.Bold, FCFont.Bold)
                .Italic = NewFC(.Italic, FCFont.Italic)
                .Underline = NewFC(.Underline, FCFont.Underline)
                .Strikethrough = NewFC(.Strikethrough, _
                  FCFont.Strikethrough)
                .ColorIndex = NewFC(.ColorIndex, FCFont.ColorIndex)
            End With
            'Change the Border Info for each of the 4 types
'            For x = 0 To 3
'                Set FCBorder = rCell.FormatConditions(ndx).Borders(iBorders(x))
'                With rCell.Borders(iBorders(x))
'                    .LineStyle = NewFC(.LineStyle, FCBorder.LineStyle)
'                    .Weight = NewFC(.Weight, FCBorder.Weight)
'                    .ColorIndex = NewFC(.ColorIndex, FCBorder.ColorIndex)
'                End With
'            Next x
            'Change the interior info
            Set FCInt = rCell.FormatConditions(ndx).Interior
            With rCell.Interior
                .ColorIndex = NewFC(.ColorIndex, FCInt.ColorIndex)
                .Pattern = NewFC(.Pattern, FCInt.Pattern)
            End With
            'Delete FC
            rCell.FormatConditions.Delete
        End If
    Next
    rWhole.Select
    Application.ScreenUpdating = True
    MsgBox ("The Formatting based on the Conditions" & vbCrLf & _
      "in the range " & rWhole.Address & vbCrLf & _
      "has been made standard for those cells" & vbCrLf & _
      "and the Conditional Formatting has been removed")
End Sub
Function NewFC(vCurrent As Variant, vNew As Variant)
    If IsNull(vNew) Then
        NewFC = vCurrent
    Else
        NewFC = vNew
    End If
End Function
Function ActiveCondition(rng As Range) As Integer
    'Chip Pearson http://www.cpearson.com/excel/CFColors.htm
    Dim ndx As Long
    Dim FC As FormatCondition
 
    If rng.FormatConditions.Count = 0 Then
        ActiveCondition = 0
    Else
    For ndx = 1 To rng.FormatConditions.Count
        Set FC = rng.FormatConditions(ndx)
        Select Case FC.Type
            Case xlCellValue
                Select Case FC.Operator
                    Case xlBetween
                        If CDbl(rng.Value) >= CDbl(FC.Formula1) And _
                          CDbl(rng.Value) <= CDbl(FC.Formula2) Then
                            ActiveCondition = ndx
                            Exit Function
                        End If
                    Case xlGreater
                        If CDbl(rng.Value) > CDbl(FC.Formula1) Then
                            ActiveCondition = ndx
                            Exit Function
                        End If
                    Case xlEqual
                        If CDbl(rng.Value) = CDbl(FC.Formula1) Then
                            ActiveCondition = ndx
                            Exit Function
                        End If
                    Case xlGreaterEqual
                        If CDbl(rng.Value) >= CDbl(FC.Formula1) Then
                            ActiveCondition = ndx
                            Exit Function
                        End If
                    Case xlLess
                        If CDbl(rng.Value) < CDbl(FC.Formula1) Then
                            ActiveCondition = ndx
                            Exit Function
                        End If
                    Case xlLessEqual
                        If CDbl(rng.Value) <= CDbl(FC.Formula1) Then
                            ActiveCondition = ndx
                            Exit Function
                        End If
                    Case xlNotEqual
                        If CDbl(rng.Value) <> CDbl(FC.Formula1) Then
                            ActiveCondition = ndx
                            Exit Function
                        End If
                    Case xlNotBetween
                        If CDbl(rng.Value) <= CDbl(FC.Formula1) Or _
                            CDbl(rng.Value) >= CDbl(FC.Formula2) Then
                            ActiveCondition = ndx
                            Exit Function
                        End If
                    Case Else
                        Debug.Print "UNKNOWN OPERATOR"
                End Select
            Case xlExpression
                If Application.Evaluate(FC.Formula1) Then
                    ActiveCondition = ndx
                    Exit Function
                End If
            Case Else
                Debug.Print "UNKNOWN TYPE"
        End Select
    Next ndx
    End If
    ActiveCondition = 0
End Function
 
Private Sub GetRange2()
'gets the range you want to highlight and sets it to be called "data"
'this is essential for your conditional formatting rule
    Dim rng As Range
    On Error Resume Next
    ActiveSheet.Select
    Set rng = Application.InputBox(prompt:="Please select the cells that you want to convert the conditional formatting on", Type:=8)
    If rng Is Nothing Then
        MsgBox "Operation Cancelled"
        Sheet1.Select
        Range("A1").Select
        Application.ScreenUpdating = True
        End
    Else
        rng.Select
        ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:=rng
    End If
End Sub
ASKER CERTIFIED SOLUTION
Join our community to see this answer!
Unlock 1 Answer and 12 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 12 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros