Question

我有一些代码可以根据匹配的引用将两行合并为一行。最初有10列，一旦组合行，它将成为20列。

代码有效，但速度很慢。它几乎就像循环表单中的每一行而不是仅仅基于＆＃34; LastRow＆＃34;变量。这是问题还是其他问题？如果我关闭更新，它仍然很慢。如果我将它们留在屏幕上，则永远闪烁，直到在任务管理器中将其杀死。

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

如果你阅读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

基于匹配ref将两行合并为一行非常慢

2 个答案: