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阵列，并对该阵列执行所有业务逻辑操作。与范围迭代相比，它将提供显着的性能提升。然后可以将结果值从该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

希望这可能会有所帮助。最好的问候，

改善细胞的红线比较

1 个答案: