提高細胞

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 

希望這有助於。最好的問候，