CODEWITHSUNDEEP
excelvba
Geographos
Geographos

Reputation: 1496

VBA Excel remove duplicate values based on values in other column

I have several codes of the same. I can remove duplicates only for these ones, which have the H-column empty. If the H column contains nonempty cell, the given code must stay.

enter image description here

I tried to work with IsEmpty() function, but it didn't work. The behaviour was as normal.

The code looks like this:

 If IsEmpty(shTarget.Range("H" & lRow)) Then
 With shTarget.Range("A" & lRow)
 .PasteSpecial xlPasteValuesAndNumberFormats
 .PasteSpecial xlPasteFormats
 .RemoveDuplicates Columns:=1, Header:=xlYes
 .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
 .WrapText = True
 End With
 End If

The approach with:

If shTarget.Range("H" & lRow) = "" Then

was exactly the same.

How can I retain the duplicate codes, which have value in other column?

UPDATE:

With this approach:

 With shTarget.Range("A" & lRow)
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
If .Range("H" & lRow).Value = "" Then
.RemoveDuplicates Columns:=1, Header:=xlYes
End If
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
.WrapText = True
End With

I have an error: Sort method of Range class failed

UPDATE II

Tried also have this one:

   For Each r In rng
   If r.Value = "" Then
   shTarget.Range("A2:H" & lRow).RemoveDuplicates Columns:=1, 
    Header:=xlYes
    End If
  Next r

it still doesn't work. Basically, no difference was observed.

My full code is:

  Sub CopyData_Cables(ByRef shSource As Worksheet, shTarget As Worksheet)

 Const VHead As String = "A1:H1"
 Const VMBom As String = "A2:H100"

 shSource.Range(VHead).Copy
 With shTarget.Range("A1")
 .PasteSpecial xlPasteValues
 .PasteSpecial xlPasteFormats

 End With


 Dim lRow As Long, lRow2 As Long
 Dim i As Integer




lRow = shTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1


shSource.Range(VMBom).Copy

Set Rng = shTarget.Range("H2" & lRow)



If IsEmpty(shTarget.Range("H" & lRow)) Then
With shTarget.Range("A" & lRow)
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
.RemoveDuplicates Columns:=1, Header:=xlYes
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
.WrapText = True
End With
End If


'If shTarget.Range("H2" & lRow) <> "" Then
'shTarget.Range("A" & lRow).Value = 0
'End If
   
'For Each r In Rng
  ' If r.Value = "" Then
  'shTarget.Range("A2:A" & lRow).Value = "Kurs!"
  ' End If
' Next r

shTarget.Columns("A").ColumnWidth = 6.11
shTarget.Columns("B").ColumnWidth = 50
shTarget.Columns("C").ColumnWidth = 50
shTarget.Columns("D").ColumnWidth = 5.44
shTarget.Columns("E").ColumnWidth = 5.89
shTarget.Columns("F").ColumnWidth = 9
shTarget.Columns("G").ColumnWidth = 21.22
shTarget.Columns("H").ColumnWidth = 10.89
shTarget.Rows.EntireRow.AutoFit


For i = 3 To lRow Step 4
shTarget.Range(shTarget.Cells(i, 1), shTarget.Cells(i, 5)).Interior.Color = RGB(235, 235, 235)
shTarget.Range(shTarget.Cells(i, 7), shTarget.Cells(i, 8)).Interior.Color = RGB(235, 235, 235)
Next i



' Reset the clipboard.
Application.CutCopyMode = xlCopy

End Sub

Upvotes: 0

Views: 152

Answers (1)

CDP1802
CDP1802

Reputation: 16382

Scan up the sheet deleting the duplicate rows.

Option Explicit

Sub RemoveDuplicates()

    Dim ws As Worksheet, dict
    Dim lastrow As Long, i As Long, n As Long
    Dim key As String
    
    Dim fso, ts
    Set fso = CreateObject("Scripting.FilesystemObject")
    Set ts = fso.CreateTextFile("debug.txt")
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Sheets("Sheet1")
    With ws
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 2 Step -1
            If Len(Trim(.Cells(i, "H"))) = 0 Then
                key = Trim(.Cells(i, "A"))
                If dict.exists(key) Then
                   '.Cells(i, "A").Interior.Color = vbRed
                   .Rows(i).Delete
                   n = n + 1
                Else
                   dict.Add key, i
                End If
            Else
                key = ""
            End If
            ts.writeline i & " A='" & .Cells(i, "A") & "' H='" _
                & .Cells(i, "H") & "' key='" & key & "' n=" & n
        Next
    End With
    ts.Close
    MsgBox n & " rows deleted", vbInformation

End Sub

Upvotes: 1

Related Questions