excel - 在 Excel 中剪切/粘贴在同一行中的重复金额

Question

我正在尝试将我的 Excel 电子表格中的重复金额移到下一列。

一般的想法是，我们文件中正确的每个金额都应该在其下方有一个副本。然后，这两个金额都需要移到一个新列中，正如您所看到的，我已经手动显示了一些。
这个文件有 3,000 多行，正在寻找一些帮助来排序这个文件。此外，如果有帮助，正确的项目应以黄色突出显示，其下方的项目以绿色突出显示。这在整张纸上是一致的。

Answer 1

将重复项剪切/粘贴到相邻列

Option Explicit

Sub matchValues()
    
    Const FirstRow As Long = 2
    
    Dim rg As Range
    With ThisWorkbook.Worksheets("Sheet1")
        Dim LastRow As Long: LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rg = .Cells(FirstRow, "A").Resize(LastRow - FirstRow + 1)
        'Set rg = .Range(.Cells(FirstRow, "A"), .Cells(LastRow, "A"))
    End With
    
    Dim Data As Variant: Data = rg.Value
    ReDim Preserve Data(1 To UBound(Data), 1 To 2)
    
    Dim srg As Range
    Dim frg As Range
    Dim mrg As Range
    Dim cCell As Range
    Dim i  As Long
    
    For i = 1 To UBound(Data, 1) - 1
        If Data(i, 1) = Data(i + 1, 1) Then
            Data(i, 2) = Data(i, 1)
            Data(i, 1) = Empty
            If mrg Is Nothing Then
                buildRange frg, rg.Cells(i)
            Else
                If Intersect(mrg, rg.Cells(i)) Is Nothing Then
                    buildRange frg, rg.Cells(i)
                End If
            End If
            buildRange mrg, rg.Cells(i + 1)
        Else
            If mrg Is Nothing Then
                buildRange srg, rg.Cells(i)
            Else
                If Intersect(mrg, rg.Cells(i)) Is Nothing Then
                    buildRange srg, rg.Cells(i)
                Else
                    Data(i, 2) = Data(i, 1)
                    Data(i, 1) = Empty
                End If
            End If
        End If
    Next i
    
    If mrg Is Nothing Then
        buildRange srg, rg.Cells(i)
    Else
        If Intersect(mrg, rg.Cells(i)) Is Nothing Then
            buildRange srg, rg.Cells(i)
        Else
            Data(i, 2) = Data(i, 1)
            Data(i, 1) = Empty
        End If
    End If
        
    rg.Resize(, 2).Clear
    rg.Resize(, 2).Value = Data
    If Not srg Is Nothing Then
        srg.Interior.Color = vbGreen
    End If
    If Not frg Is Nothing Then
        frg.Offset(, 1).Interior.Color = vbYellow
        mrg.Offset(, 1).Interior.Color = vbGreen
    End If

End Sub

Sub buildRange( _
        ByRef BuiltRange As Range, _
        ByVal AddRange As Range)
    If BuiltRange Is Nothing Then
        Set BuiltRange = AddRange
    Else
        Set BuiltRange = Union(BuiltRange, AddRange)
    End If
End Sub