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

Posted 2023-03-29

【中文标题】在 Excel 中剪切/粘贴在同一行中的重复金额

【英文标题】：Cut/Pasting Duplicates Amounts in Excel That are in the Same Row

【发布时间】：2021-06-23 16:59:18

【问题描述】：

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

一般的想法是，我们文件中正确的每个金额都应该在其下方有一个副本。然后需要将这两个金额移到一个新列中，如您所见，我已经手动显示了一些。

这个文件有 3,000 多行，正在寻找一些帮助来排序这个文件。此外，如果有帮助，正确的项目应以黄色突出显示，其下方的项目以绿色突出显示。这在整个工作表中是一致的。

【问题讨论】：

在 F2 =IF(OR(E2=E1, E2=E3), E2, "") 中并向下拖动。复制/粘贴 F 中的值，然后对该列进行排序并从 E 中删除相应的值。您可以在 Col F 中使用条件格式进行黄色/绿色着色。

@TimWilliams 将此添加为响应

【参考方案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