根據匹配ref將兩行合併爲一個非常慢

Question

我有一些代碼將兩行合併爲一個基於匹配引用的代碼。最初有10列，一旦行被組合，它將變成20列。

該代碼有效，但速度很慢。它幾乎就像循環表格中的每一行，而不僅僅是基於「LastRow」變量。這是問題還是其他問題？ 如果我關閉更新，它仍然很慢。如果我將它們留在屏幕上，只會一直閃爍，直到在任務管理器中關閉它爲止。

Sub CombineRows() 
    'define variables 
    Dim RowNum As Long, LastRow As Long 
    Application.ScreenUpdating = False 
    'start below titles and make full selection of data 
    RowNum = 2 
    LastRow = Range("A" & Rows.Count).End(xlUp).Row 
    Range("A2", Cells(LastRow, 10)).Select 
    'For loop for all rows in selection with cells 
    For Each Row In Selection 
     With Cells 
     'if order number matches 
      If Cells(RowNum, 4) = Cells(RowNum + 1, 4) Then 
       'move attribute 2 up next to attribute 1 and delete empty line 
       Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 11) 
       Cells(RowNum + 1, 2).Copy Destination:=Cells(RowNum, 12) 
       Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 13) 
       Cells(RowNum + 1, 4).Copy Destination:=Cells(RowNum, 14) 
       Cells(RowNum + 1, 5).Copy Destination:=Cells(RowNum, 15) 
       Cells(RowNum + 1, 6).Copy Destination:=Cells(RowNum, 16) 
       Cells(RowNum + 1, 7).Copy Destination:=Cells(RowNum, 17) 
       Cells(RowNum + 1, 8).Copy Destination:=Cells(RowNum, 18) 
       Cells(RowNum + 1, 9).Copy Destination:=Cells(RowNum, 19) 
       Cells(RowNum + 1, 10).Copy Destination:=Cells(RowNum, 20) 
       Rows(RowNum + 1).EntireRow.Delete 
      End If 
     End With 
     'increase rownum for next test 
     RowNum = RowNum + 1 
    Next Row 
    'turn on screen updating 
    Application.ScreenUpdating = True 
End Sub 

Answer 1

我認爲什麼把它慢是多重複制和粘貼其中你可以做到這一點一氣呵成。
此外，如果您僅檢查列4，那麼只需在那裏循環。
另一件重要的事情是，您複製後無法刪除該行。
行將移動，然後你不會得到預期的結果。
嘗試先完成這些行並在完成迭代後一次刪除。
嘗試的東西有點清潔和直接：

EDIT1：審覈您的代碼後，似乎您試圖重複在同一行結合起來。

Sub CombineRows() 
    Dim RowNum As Long, LastRow As Long 
    Dim c As Range, rngtodelete As Range 
    Application.ScreenUpdating = False 
    With Sheets("Sheet1") 
     RowNum = 2 
     LastRow = .Range("A" & Rows.Count).End(xlUp).Row 
     For Each c In .Range("D2:D" & LastRow) 'Loop in D column only 
      If c.Value2 = c.Offset(1, 0).Value2 Then 
       'Cut and paste in one go 
       c.Offset(1, -3).Resize(, 10).Cut .Range("K" & RowNum) 
       'Mark the rows to delete 
       If rngtodelete Is Nothing Then 
        Set rngtodelete = c.Offset(1, 0).EntireRow 
       Else 
        Set rngtodelete = Union(rngtodelete, c.Offset(1, 0).EntireRow) 
       End If 
      End If 
      RowNum = RowNum + 1 
     Next 
     If Not rngtodelete Is Nothing Then rngtodelete.Delete xlUp 'Delete in one go 
    End With 
    Application.ScreenUpdating = True 
End Sub 

如果您閱讀POST，您也可以學到很多東西。
我真的不知道這是否是你想要實現的。
我僅基於您發佈的代碼進行了基礎。這在我的機器上花費了不到一秒鐘的時間。 HTH。

Answer 2

你應該試試這個：

Sub CombineRows() 
    'define variables 
    Dim RowNum As Long, LastRow As Long 
    Application.ScreenUpdating = False 
    'start below titles and make full selection of data 
    RowNum = 2 
    LastRow = Range("A" & Rows.Count).End(xlUp).Row 
    'Range("A2", Cells(LastRow, 10)).Select 
    'For loop for all rows in selection with cells 
    'For Each Row In Selection 
    ' With Cells 
     'if order number matches 
    With Worksheets("ABC") ' Whatever is the Tab name 
     For RowNum = 2 To LastRow 
      If .Cells(RowNum, 4) = .Cells(RowNum + 1, 4) Then 
       'move attribute 2 up next to attribute 1 and delete empty line 
       .Range(.Cells(RowNum + 1, 1), .Cells(RowNum + 1, 10)).Copy _ 
         Destination:=.Range(.Cells(RowNum, 11), .Cells(RowNum, 20)) 
       'Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 11) 
       'Cells(RowNum + 1, 2).Copy destination:=Cells(RowNum, 12) 
       'Cells(RowNum + 1, 3).Copy destination:=Cells(RowNum, 13) 
       'Cells(RowNum + 1, 4).Copy destination:=Cells(RowNum, 14) 
       'Cells(RowNum + 1, 5).Copy destination:=Cells(RowNum, 15) 
       'Cells(RowNum + 1, 6).Copy destination:=Cells(RowNum, 16) 
       'Cells(RowNum + 1, 7).Copy destination:=Cells(RowNum, 17) 
       'Cells(RowNum + 1, 8).Copy destination:=Cells(RowNum, 18) 
       'Cells(RowNum + 1, 9).Copy destination:=Cells(RowNum, 19) 
       'Cells(RowNum + 1, 10).Copy destination:=Cells(RowNum, 20) 
       Rows(RowNum + 1).EntireRow.Delete 
      End If 
     Next 
     'End With 
    End With 
     'increase rownum for next test 
     RowNum = RowNum + 1 
    'Next Row 
    'turn on screen updating 
    Application.ScreenUpdating = True 
End Sub