CODEWITHSUNDEEP
excelvbaduplicates
nleopard
nleopard

Reputation: 21

Cut/Pasting Duplicates Amounts in Excel That are in the Same Row

I'm trying to move repeated amounts in my Excel spreadsheet to the next column over.

The general idea is that each amount that that is correct in our file should have a duplicate right below it. Both of these amounts then need to be moved into a new column, as you can see I've manually shown done a few.

This file has 3,000+ lines, was looking for some help sorting this file. Also, if it helps the items that are correct should be highlighted yellow, with the one below it being highlighted green. This is consistent throughout the whole sheet.

Upvotes: 2

Views: 48

Answers (1)

VBasic2008
VBasic2008

Reputation: 54815

Cut/Paste Duplicates to Adjacent Column

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

Upvotes: 2

Related Questions