Применение форматирования текста к строкам внутри ячейки

Question

У меня есть ячейка, которая содержит разделенный запятыми список пар Part * Number.

Действительные пары

• Часть * Количество
• Количество * Часть
• Часть

Часть является строкой или указанным числом, а количество является числом

Пример действительного значения ячейки

Part1,Part2*2,3*Part3,"12332","2123"*3

Пример неверного значения ячейки

Part1**5,12332*3,Part2*Part2

Цель

Значение ячейки вводится пользователем вручную, и мне нужно проверить, что каждый элемент в списке действителен, когда пользователь запускает макрос проверки.

Пока я делаю это, я также помещаю элементы в один и тот же формат и объединяю любые повторяющиеся записи.

Недопустимые записи перемещаются в начало списка.

Сейчас я пытаюсь выделить недопустимые записи, установив красный цвет шрифта и выделив его жирным шрифтом (только для каждого недопустимого элемента).

Я сделал (код не впечатляющий ...) большую часть, но выделение просто не сработает. Я возился с этим некоторое время, но не могу заставить его работать. http://pastebin.com/CSrU66iz

Public Sub validateList(ByVal ListRange As Range)
Dim List As Dictionary
Dim Problem As Dictionary
Dim Items() As String
Dim Pairs() As String
Dim Item As Variant
Dim Pair As Variant
Dim Output As String
Dim Position As Integer

    Set List = New Dictionary
    Set Problem = New Dictionary

    Items = Split(ListRange.Value, Main.LST_SEPERATOR)

    Invalid = ""

    For Each Item In Items
        Item = Trim(Item)
        Pairs = Split(Item, Main.QTY_SEPERATOR)
        For Each Pair In Pairs
            Pair = Trim(Pair)
        Next Pair
        Select Case UBound(Pairs)
        Case 1
            ' Part and Quantity
            If CStr(Main.parseInteger(Pairs(0))) = Pairs(0) Then
                ' Pairs(0) Probably Quantity
                If CStr(Main.parseInteger(Pairs(1))) = Pairs(1) Then
                    ' Problem! Both Pairs(0) and Pairs(1) are Numbers
                    Problem.Add Pairs(0) & Main.QTY_SEPERATOR & Pairs(1), 0
                Else
                    ' Pairs(0) = Quantity, Pairs(1) = Part
                    If List.Exists(Pairs(1)) = False Then
                        List.Add Pairs(1), Main.parseInteger(Pairs(0))
                    Else
                        List(Pairs(1)) = List(Pairs(1)) + Main.parseInteger(Pairs(0))
                    End If
                End If
            Else
                ' Pairs(0) Probably Part
                If CStr(Main.parseInteger(Pairs(1))) = Pairs(1) Then
                    ' Pairs(0) = Part, Pairs(1) = Quantity
                    If List.Exists(Pairs(0)) = False Then
                        List.Add Pairs(0), Main.parseInteger(Pairs(1))
                    Else
                        List(Pairs(0)) = List(Pairs(0)) + Main.parseInteger(Pairs(1))
                    End If
                Else
                    ' Problem! Both Pairs(0) and Pairs(1) are Strings
                    Problem.Add Pairs(0) & Main.QTY_SEPERATOR & Pairs(1), 0
                End If
            End If
        Case 0
            ' Part Only
            If List.Exists(Pairs(0)) = False Then
                List.Add Pairs(0), 1
            Else
                List(Pairs(0)) = List(Pairs(0)) + 1
            End If
        Case Else
            Problem.Add Item, 0
        End Select
    Next Item

    Position = 1

    ListRange.Value = ""

    For Each Item In Problem.Keys
        If Not ListRange.Value = "" Then
            ListRange.Value = ListRange.Value & ", "
            Debug.Print Position
            With ListRange.Characters(Start:=Position, Length:=2)
                .Font.Color = RGB(0, 0, 0)
                .Font.Bold = False
            End With
            Position = Position + 2
        End If

        Output = Item

        ListRange.Value = ListRange.Value & Output
        With ListRange.Characters(Start:=Position, Length:=Len(Item))
            .Font.Color = RGB(255, 0, 0)
            .Font.Bold = True
        End With
        Position = Position + Len(Item)
    Next Item

    For Each Item In List.Keys
        If Not ListRange.Value = "" Then
            ListRange.Value = ListRange.Value & ", "
            With ListRange.Characters(Start:=Position, Length:=2)
                .Font.Color = RGB(0, 0, 0)
                .Font.Bold = False
            End With
            Position = Position + 2
        End If

        If List(Item) = 1 Then
            Output = Item
        Else
            Output = Item & Main.QTY_SEPERATOR & List(Item)
        End If

        ListRange.Value = ListRange.Value & Output
        With ListRange.Characters(Start:=Position, Length:=Len(Output))
            .Font.Color = RGB(0, 0, 0)
            .Font.Bold = False
        End With
        Position = Position + Len(Item)
    Next Item

End Sub

Примечание

• Для работы словаря вам потребуется ссылка на «Microsoft Scripting Runtime».
• Main.parseInteger () немного похож на CInt ()
• Main.LST_SEPERATOR является константой с "," в
• Main.QTY_SEPERATOR является константой с "*" в
• Я не так хорош, чтобы задавать вопросы

Answer 1

После просмотра кода, применяя форматирование, я увидел, что оно нарушает форматирование, примененное предыдущими итерациями.

Мне удалось обойти это, сгенерировав вывод и еще одну версию с «триггерами» вокруг битов, которые хотят отформатировать по-разному.

В качестве значения ячейки задана неотформатированная строка, после чего к ней применяется форматирование с использованием версии с триггером (вероятно, это не лучшее объяснение!)

Результат

конечный результат http://dl.dropbox.com/u/10316127/formatting.png

Вот код, если кому-то интересно:)

Public Sub validateList(ByVal List As Range)
Dim Valid As Dictionary
Dim Invalid As Dictionary
Dim Items() As String
Dim Item As Variant
Dim Data() As String
Dim Quantity As Integer
Dim Output As String
Dim OutputFormat As String
Dim S As Variant

Dim Position As Integer
Dim Mark As Integer
Dim Offset As Integer
Dim State As Boolean

    Set Valid = New Dictionary
     Set Invalid = New Dictionary

     Items = Split(Expression:=List.Value, Delimiter:=Main.LST_SEPERATOR, Compare:=vbTextCompare)

     For Each Item In Items

        Item = Trim(Item)

        Data = Split(Expression:=Item, Delimiter:=Main.QTY_SEPERATOR, Compare:=vbTextCompare, Limit:=2)

        For Each S In Data
            S = Trim(S)
        Next S

        If Len(Item) - Len(Replace(Item, Main.QTY_SEPERATOR, "")) > 1 Then
' error - multiple seperators detected
            Invalid.Add Data(0), Data(1)
        Else
            Select Case UBound(Data)
            Case 0
            ' Part Only
                If Not Data(0) Like Chr(34) & "*" & Chr(34) Then
                    Data(0) = Chr(34) & Replace(Data(0), Chr(34), "") & Chr(34)
                End If
                If Valid.Exists(Data(0)) = False Then
                    Valid.Add Data(0), 1
                Else
                    Valid(Data(0)) = Valid(Data(0)) + 1
                End If
            Case 1
            ' Part AND Quantity
                If Data(0) Like Chr(34) & "*" & Chr(34) Then
                    If Data(1) Like Chr(34) & "*" & Chr(34) Then
' error - both parts quoted
                        Invalid.Add Data(0), Data(1)
                    Else
                        Quantity = Main.parseInteger(Data(1))
                        If Quantity = 0 Then
' error - quantity evaluates to zero
                            Invalid.Add Data(0), Data(1)
                        Else
' valid
                            If Valid.Exists(Data(0)) = False Then
                                Valid.Add Data(0), Quantity
                            Else
                                Valid(Data(0)) = Valid(Data(0)) + Quantity
                            End If
                        End If
                    End If
                Else
                    If Data(1) Like Chr(34) & "*" & Chr(34) Then
                        Quantity = Main.parseInteger(Data(0))
                        If Quantity = 0 Then
' error - quantity evaluates to zero
                            Invalid.Add Data(0), Data(1)
                        Else
' valid
                            If Valid.Exists(Data(1)) = False Then
                                Valid.Add Data(1), Quantity
                            Else
                                Valid(Data(1)) = Valid(Data(1)) + Quantity
                            End If
                        End If
                    Else
' error - no quoted part
                        Invalid.Add Data(0), Data(1)
                    End If
                End If
            End Select
        End If
     Next Item

    Output = ""
    OutputFormat = ""

    For Each Item In Invalid.Keys
        If Not Output = "" Then
            Output = Output & Main.LST_SEPERATOR
            OutputFormat = OutputFormat & Main.LST_SEPERATOR
        End If
        Output = Output & Item & Main.QTY_SEPERATOR & Invalid(Item)
        OutputFormat = OutputFormat & "[]" & Item & Main.QTY_SEPERATOR & Invalid(Item) & "[]"
     Next Item

    For Each Item In Valid.Keys
        If Not Output = "" Then
            Output = Output & Main.LST_SEPERATOR
            OutputFormat = OutputFormat & Main.LST_SEPERATOR
        End If
        If Valid(Item) = 1 Then
            Output = Output & Item
            OutputFormat = OutputFormat & Item
        Else
            Output = Output & Item & Main.QTY_SEPERATOR & Valid(Item)
            OutputFormat = OutputFormat & Item & Main.QTY_SEPERATOR & Valid(Item)
        End IF
     Next Item

    List.Value = Output

    With List.Characters(Start:=1).Font
        .Color = vbBlack
        .Bold = False
    End With

    Position = 1
    Offset = 1
    State = Empty

    Do While Position < Len(Output)
        If Mid(OutputFormat, Offset, 2) = "[]" Then
            Offset = Offset + 2
            If IsEmpty(State) = True Then
                State = True
                Mark = Position
            Else
                If State = True Then
                    With List.Characters(Start:=Mark, Length:=Position - Mark).Font
                        .Color = vbRed
                        .Bold = True
                    End With
                    State = False
                Else
                    State = True
                    Mark = Position
                End If
            End If
        Else
            Position = Position + 1
            Offset = Offset + 1
        End If
     Loop
End Sub

Опять же, вам нужно обратиться к среде выполнения сценариев Microsoft для словаря.

Вот код для parseInteger ()

Public Function parseInteger(ByVal S As Variant) As Integer
On Error GoTo errHandler
Dim Result As Integer
Dim Text As String
Dim Size As Integer
Dim Character As String
Dim Index As Integer

    If TypeName(S) = "Range" Then
        S = S.Cells(1, 1).Value
    End If
    S = CStr(S)
    Size = Len(S)
    Text = ""

    For Index = 1 To Size
        Character = Mid(S, Index, 1)
        If Character Like "#" Then
            Text = Text & Character
        End If
    Next Index

    If Text = "" Then
        parseInteger = 0
    Else
        parseInteger = CInt(Text)
    End If

Exit Function
errHandler:
    Debug.Print "[error] Main.parseInteger()"
End Function