改善细胞的红线比较

我正在使用Excel 2010。

我有一些工作的VBA代码，比较两个单元格（从文本到文本），并生成红色的文本到第三个单元格删除线上删除线，强调增加的单词。 这不是单元格内容的直接组合。

代码的作品，但我认为它可以更有效地使用multidimensional array来存储的东西，而不是使用额外的单元格和重新组合。 但我坚持如何实施它。 我还想确定突破点的位置，特别是对于我还没有的新版本的Excel，因为单元格中允许的字符数似乎随着每个新版本的不断增长而增加。

也欢迎评论。

工作代码：

Sub main() Cells(3, 3).Clear Call Redline(3) End Sub Sub Redline(ByVal r As Long) Dim t As String Dim t1() As String Dim t2() As String Dim i As Integer Dim j As Integer Dim f As Boolean Dim c As Integer Dim wf As Integer Dim ss As Integer Application.ScreenUpdating = False t1 = Split(Range("A" + CStr(r)).Value, " ", -1, vbTextCompare) t2 = Split(Range("B" + CStr(r)).Value, " ", -1, vbTextCompare) t = "" f = False c = 4 ss = 0 If (Range("A" + CStr(r)).Value <> "") Then If (Range("B" + CStr(r)).Value <> "") Then j = 1 For i = LBound(t1) To UBound(t1) f = False For j = ss To UBound(t2) If (t1(i) = t2(j)) Then f = True wf = j Exit For End If Next j If (Not f) Then Cells(r, c).Value = t1(i) Cells(r, c).Font.Strikethrough = True ' strikethrough this cell c = c + 1 Else If (wf = i) Then Cells(r, c).Value = t1(i) ' aka t2(wf) c = c + 1 ss = i + 1 ElseIf (wf > i) Then For j = ss To wf - 1 Cells(r, c).Value = t2(j) Cells(r, c).Font.Underline = xlUnderlineStyleSingle ' underline this cell c = c + 1 Next j Cells(r, c).Value = t1(i) c = c + 1 ss = wf + 1 End If End If Next i If (UBound(t2) > UBound(t1)) Then For i = ss To UBound(t2) Cells(r, c).Value = t2(i) Cells(r, c).Font.Underline = xlUnderlineStyleSingle ' underline this cell c = c + 1 Next i End If Else t = Range("A" + CStr(r)).Value End If Else t = Range("B" + CStr(r)).Value End If lc = Range("XFD" + CStr(r)).End(xlToLeft).Column Call Merge_Cells(r, 4, lc) Application.ScreenUpdating = True End Sub Sub Merge_Cells(ByVal r As Long, ByVal fc As Integer, ByVal lc As Long) Dim i As Integer, c As Integer, j As Integer Dim rngFrom As Range Dim rngTo As Range Dim lenFrom As Integer Dim lenTo As Integer Set rngTo = Cells(r, 3) ' copy the text over For c = fc To lc lenTo = rngTo.Characters.Count Set rngFrom = Cells(r, c) lenFrom = rngFrom.Characters.Count If (c = lc) Then rngTo.Value = rngTo.Text & rngFrom.Text Else rngTo.Value = rngTo.Text & rngFrom.Text & " " End If Next c ' now copy the formatting j = 0 For c = fc To lc Set rngFrom = Cells(r, c) lenFrom = rngFrom.Characters.Count + 1 ' add one for the space after each word For i = 1 To lenFrom - 1 With rngTo.Characters(j + i, 1).Font .Name = rngFrom.Characters(i, 1).Font.Name .Underline = rngFrom.Characters(i, 1).Font.Underline .Strikethrough = rngFrom.Characters(i, 1).Font.Strikethrough .Bold = rngFrom.Characters(i, 1).Font.Bold .Size = rngFrom.Characters(i, 1).Font.Size .ColorIndex = rngFrom.Characters(i, 1).Font.ColorIndex End With Next i j = j + lenFrom Next c ' wipe out the temporary columns For c = fc To lc Cells(r, c).Clear Next c End Sub 

Answer 1

您可以直接将Excel Range对象分配给VBA 2d数组，并对该数组执行所有业务逻辑操作。 它将提供大幅的性能提升与范围迭代。 然后结果值可以从该2d数组插入到Excel工作表列中。

示例代码片段如下：

 Sub Range2Array() Dim arr As Variant arr = Range("A:B").Value 'alternatively 'arr = Range("A:B") 'test Debug.Print (arr(1, 1)) End Sub 

另一个有用的技术是将Excel的UsedRange分配给VBA数组：

 arr = ActiveSheet.UsedRange 

希望这可能有帮助。 最好的祝福，