将两行合并为一个基于匹配的ref很慢

我有一些代码将两行合并为一个基于匹配的引用。 最初有10列，一旦行被组合，它将变成20列。

代码有效，但速度很慢。 这几乎就像循环表格中的每一行，而不仅仅是基于“LastRow”variables。 这是问题还是别的？ 如果我closures更新，它仍然很慢。 如果我把它们留在屏幕上，只会永远闪烁，直到在任务pipe理器中杀死它。

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列 ，那么只是在那里循环。
另一个重要的是你复制后不能删除行。
行将移动，然后你不会得到预期的结果。
尝试获取这些行，并在完成迭代后一次删除。
尝试一些清洁和直接的东西：

编辑1：在审查你的代码后，似乎你正在尝试在同一行组合重复。

 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 

如果你阅读这篇文章，你也可以学到很多东西。
我真的不知道这是否是你想要实现的。
我只根据您发布的代码进行build立。 这在我的机器上花了不到一秒钟的时间。 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