提高细胞

Question

我使用Excel 2010中

的红线比较我有一些工作VBA代码是比较两个细胞（来自文本，文本），并且产生的红线文本到第三细胞与对已移除的话删除线，强调增加的单词。这不是单元格内容的直接组合。

该代码有效，但我认为使用多维数组来存储事物而不是使用其他单元格和重新组合可以更高效。但我坚持如何实施它。我还想确定突破点的位置，特别是对于我还没有的新版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数组插入到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 

希望这有助于。最好的问候，