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

Question

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

Правильные пар

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

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

Пример Valid Cell Value

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

Пример Недопустимый Cell Value

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

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

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

значение ячейки устанавливается в неформатированный строку, то форматирование применяется к нему, используя trigger'ed версию (вероятно, не самое лучшее объяснение!)

Результат

end result 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 

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

Вот код для 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