CODEWITHSUNDEEP
excelvbamacroscopyduplicates
M. Primrose
M. Primrose

Reputation: 15

How to look at two columns and delete duplicates in second column

I'm trying to write a code that will allow me to look at two very similar columns, and clear the cell of the duplicate in the second column if it already exists in the first column. I have a code that is sort of working, but it is deleting some of the duplicates and moving them upwards, but I want them to remain in their original cell. I essentially want it to say "if the cell exists in column1 and column 2, clear the cell in column 2". I'm not sure if this is possible. Here is the code I have been working with. Any help would be greatly appreciated! 

Sub CopyPasteHistorical()

CopyPasteHistorical Macro

Sheets("Sheet1").Select

Columns("I:I").Select
Selection.copy
Sheets("Sheet2").Select
Columns("D:D").Select
ActiveSheet.Paste
'remove duplicates
Columns("C:D").Select
Dim duplicates As Range
Set duplicates = Selection
Selection.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

End Sub

Upvotes: 0

Views: 642

Answers (2)

user3598756
user3598756

Reputation: 29421

I'd go the opposite way, like following (commented) code:

Option Explicit

Sub CopyPasteHistorical()
    Dim sht1Rng As Range, cell As Range

    With Worksheets("Sheet1") '<-- reference Sheet1
        Set sht1Rng = .Range("I1", .Cells(.Rows.Count, "I").End(xlUp)).SpecialCells(xlCellTypeConstants) '<-- set range with its column "I" cells containing constant (i.e. not formulas) values
    End With

    With Worksheets("Sheet2") '<-- reference Sheet2
        For Each cell In sht1Rng '<-- loop through Sheet1 range
            If cell.Value <> .Cells(cell.Row, "C") Then .Cells(cell.Row, "D") = cell.Value '<-- if sheet1 current cell content is different from Sheet2 column "C" cell content in the same row then write it in Sheet 2 column "D" corresponding row
        Next cell
    End With
End Sub

this way you:

  • only bother with Sheet1 column "I" relevant cells (i.e. not blank ones)

  • don't make unnecessary copy&paste

  • only write wanted values in Sheet2

Upvotes: 0

gg2104
gg2104

Reputation: 39

To do what Scott is talking about, you can try the following:

Sub Test()
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim ws As Worksheet
    Set ws = wb.Sheets("Sheet1")

    'get the last row of the 1st column, "A" in this case
    Dim lastRow As Integer
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row


    Dim i As Integer
    'loop through all the rows of column A
    For i = 1 To lastRow
        'get value of cell, find and replace with "" in column "B"
        Dim curVal
        curVal = ws.Range("A" & i).Value
        ws.Columns("B").Replace _
            What:=curVal, Replacement:="", _
            SearchOrder:=xlByColumns, MatchCase:=True
    Next i


End Sub

This will replace the duplicates in column B with a blank instead of deleting/shifting upwards.

Upvotes: 1

Related Questions