查找具有相同值和收缩单元格的行

Question

我正在尝试查找具有相同值的单个列中的所有行。除了其中一列之外，程序应该删除多次出现的所有行，这些行应该从已删除的行中收缩所有语句。这是我到目前为止，但我得到一个循环错误：

Sub tester()
    Sheets("Sheet1").Select
    Dim one As Integer
        one = 2
    Dim log As Integer
        log = 2
    Dim compare As Integer
        compare = one + 1
    Dim ws As String
        ws = "Sheet1"
    Dim ender As String
        ender = "Sheet4"
    Dim counter As Integer
        counter = 0
    Dim lastrow As Integer
        lastrow = Cells(Rows.Count, 1).End(xlUp).row
    For log = 2 To lastrow - 1
        one = log + counter
        compare = one + 1
        If Worksheets(ws).Cells(one, 1).Value = Worksheets(ws).Cells(compare,1).Value And Worksheets(ws).Cells(one, 7).Value = Worksheets(ws).Cells(compare, 7).Value Then
            Do While Worksheets(ws).Cells(one, 1).Value = Worksheets(ws).Cells(compare, 1).Value And Worksheets(ws).Cells(one, 7).Value = Worksheets(ws).Cells(compare, 7).Value
                If compare = one + 1 Then
                    Worksheets(ender).Cells(log, 1).Value = Worksheets(ws).Cells(one, 1).Value
                    Worksheets(ender).Cells(log, 4).Value = Worksheets(ws).Cells(one, 4).Value
                   Worksheets(ender).Cells(log, 2).Value = Worksheets(ws).Cells(one, 2).Value
                   Worksheets(ender).Cells(log, 7).Value = Worksheets(ws).Cells(one, 7).Value
                End If
                Worksheets(ender).Cells(log, 4).Value = Worksheets(ender).Cells(log, 4).Value & "; " & Worksheets(ws).Cells(compare, 4).Value
                compare = compare + 1
                counter = counter + 1
            Loop
        ElseIf Worksheets(ws).Cells(one, 1).Value <> Worksheets(ws).Cells(compare, 1).Value Then
            Worksheets(ender).Cells(one - counter, 1).Value = Worksheets(ws).Cells(one, 1).Value
            Worksheets(ender).Cells(one - counter, 2).Value = Worksheets(ws).Cells(one, 2).Value
            Worksheets(ender).Cells(one - counter, 3).Value = Worksheets(ws).Cells(one, 3).Value
            Worksheets(ender).Cells(one - counter, 4).Value = Worksheets(ws).Cells(one, 4).Value
            Worksheets(ender).Cells(one - counter, 5).Value = Worksheets(ws).Cells(one, 5).Value
            Worksheets(ender).Cells(one - counter, 7).Value = Worksheets(ws).Cells(one, 7).Value
        End If
    Next log
    Sheets("Sheet4").Select
End Sub

原始数据

期望的输出