我有一个包含部分*数量对的逗号分隔列表的单元格。
有效对
Part是字符串或带引号的数字，而数量是数字
有效单元格值的示例
Part1,Part2*2,3*Part3,"12332","2123"*3
无效单元格值的示例
Part1**5,12332*3,Part2*Part2
目标
Cell值是由用户手动输入的，我需要在用户运行验证宏时检查列表中的每个项是否有效。
当我这样做的时候，我也会把这些项目放在相同的格式中并合并任何重复的条目。
无效的条目将移至列表的开头。
我现在要做的是通过将字体颜色设置为红色并使其变为粗体（仅针对每个无效项目）来突出显示无效条目。
我已经完成了（代码并不壮观......）大部分内容，但突出显示不会起作用。我一直在摆弄它已经有一段时间但是无法让它发挥作用。 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
注意
答案 0 :(得分：0)
在单步执行代码后，看着它应用格式化，我看到它打破了之前迭代所应用的格式。
我设法通过生成输出来解决这个问题，另一个版本的输出带有“触发器”，它们围绕着想要格式不同的位。
Cell值设置为未格式化的字符串，然后使用触发版本对其应用格式化（可能不是最好的解释！）
<强>结果
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
同样，您需要引用Microsoft Scripting Runtime for Dictionary。
这是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