How do I fix this? Delete Duplicate Columns

[ParanoidAndroid]

Hi Excel Experts

I really appreciate your help with this

I have adapted this excel code i found online. This code looks for duplicates in column V and then deletes that row with the duplicate.

There is however a slight quirk -

The sheet has a range (A:U) which is linked to a database in Sharepoint. So when deleting the row based on duplicate cell in column V I need to

1) Delete the duplicate cell in column V and shift up that cell
ie: Range("V" & CStr(LTestLoop)).Select
Range("V" & CStr(LTestLoop)).Delete Shift:=xlUp

2) select a cell from the row I want to delete in the linked range and delete that row
ie. something like Selection.ListObject.ListRows.Delete

This is because it doesnt seem possible to use EntireRow.Delete when you have a linked range(to Sharepoint).

He is the code i've adapted...it seems to work except i'm not sure how to adapt 2) see "delete duplicates

Sub TestForDuplicates()
    Dim LLoop As Integer
    Dim LTestLoop As Integer
    Dim Lrows As Integer
    Dim LRange As String
    Dim LCnt As Integer
    'Column values
    Dim LColV_1 As String
    
    
    Lrows = Range("V2").End(xlDown).Row
    LLoop = 2
    LCnt = 0
    
    'Check until last used row in column V
    While LLoop <= Lrows
        LColV_1 = "V" & CStr(LLoop)
       
        If Len(Range(LColV_1).Value) > 0 Then
            'Test each value for uniqueness
            LTestLoop = LLoop + 1
            While LTestLoop <= Lrows
                If LLoop <> LTestLoop Then
                    LColV_2 = "V" & CStr(LTestLoop)
                    
                    'Value has been duplicated in another cell of the same coluumn which is column V)
                    If (Range(LColV_1).Value = Range(LColV_2).Value) _
                      Then
                        'Delete the duplicate
                        Rows(CStr(LTestLoop) & ":" & CStr(LTestLoop)).Select
                        Selection.ListObject.ListRows(LTestLoop).Delete             'deletes a row within the range linked to sharepoint database
                        Rows(CStr(LTestLoop) & ":" & CStr(LTestLoop)).Select
                        Range("V" & CStr(LTestLoop)).Select                 'deletes the cells tested in column that is outside the linked sharepoint database otherwise it gets stuck in a loop
                        Range("V" & CStr(LTestLoop)).Delete Shift:=xlUp
                        'Decrement counter since row was deleted
                        
                        LTestLoop = LTestLoop - 1
                        LCnt = LCnt + 1
                    End If
                End If
                LTestLoop = LTestLoop + 1
            Wend
        End If
        LLoop = LLoop + 1
    Wend
  
 
End Sub

 

[Krishnakumar]

Hi,

I should have tested the code before posting

replace

ReDim k(1 To UBound(ka, 1), 1 To 1)

with

ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))

HTH

 

[ParanoidAndroid]

Hi Krish

That code works great when i tested on a fresh sheet and i most appreciate you help. Thank you very much

but as previously explained rows A:U are part of a "linked" sheet to "Sharepoint" in the sheet i will be using. The way these rows need to be deleted seems to be different to the conventional way as you have done.

Your code needs to be used to delete to duplicates in column V but a different format needs to be used to delete the duplicates in the linked range A:U in Sharepoint.

If i run the macro recorder to delete the row in the "linked" range - the following steps are required (manually) -

1) right click on any cell within linked range of the row where a duplicate is found in column V (which is outside the duplicate range). In this example i selected A2
2) Select delete, select Row
- it will then delete 'that' row from A:U which is within the linked range. It does not touch column V onlward as they are outside the linked range.

The macro recorder applied the following code

Sheets("MO_Linked").Select
    Range("A2").Select
    Selection.ListObject.ListRows(1).Delete

Is there any way we can adapt this step to fit within your code? I hope im making sense

Let me know if so or if not. Regardingless...you have been a big help and i much appreciate it.

 

[Krishnakumar]

Hi,

I'm not sure about this, but what about delete whole range, paste new data and link the new data into Sharepoint ?

 

[ParanoidAndroid]

Thats ok Krish. Thanks for your help, i really appreciate it.

I actually have a bit of an idea of what needs to be done. I just dont know how to do it. If you are willing - we can work it out together?

If we go back an use your original solution. This is the one that looks for the duplicates in column V. Nothing needs to be changes but a few things need to be added.

In your solution - you defined what "r" is.

r is the Range counter that looks for the duplicates. So what i need to do is whn r = a duplicate cell = it clears the cell in column V. This is good and should not be touched but r then needs to be redefined with the same cell as the duplicate but in the previous column (column U). So it would be something like .offset(r,-1) ?? how do i do this?

when this is done - im confident that i can then do

Selection.ListObject.ListRows(r).Delete

so the end result would be code like (taken from you code)

With r
        .ClearContents
        r = range(r).offset(0,-1).selection
        Selection.ListObject.ListRows(r).Delete
        .Value2 = k
    End With

see what im getting at? so it first deletes the duplicate in column v outside the the linked range. The counter then moves over one column but same row and deletes the row in the linked area Selection.ListObject.ListRows(1).Delete

 

[Krishnakumar]

Hi,

Give this a try.

Caution: Please save a copy of your workbook before testing this code

Sub kTest()
    Dim ka, k(), i As Long, n As Long, c As Long
    Dim Hdr, lstObj As ListObject, strLstName   As String
    
    With ActiveSheet
        On Error Resume Next
        Set lstObj = .ListObjects(1)
        On Error GoTo 0
        If lstObj Is Nothing Then
            MsgBox "No list object exist in active sheet", vbInformation
            Exit Sub
        End If
        strLstName = lstObj.Name
        Hdr = lstObj.HeaderRowRange
        ka = Range("a2:v" & .Range("v" & .Rows.Count).End(xlUp).Row)
    End With
    ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(ka, 1)
            If Len(ka(i, 22)) Then
                If Not .exists(ka(i, 22)) Then
                    n = n + 1
                    For c = 1 To UBound(ka, 2)
                        k(n, c) = ka(i, c)
                    Next
                    .Add ka(i, 22), Nothing
                End If
            End If
        Next
    End With
    
    lstObj.Delete
    Set lstObj = Nothing
    With Range("a1")
        .Resize(, UBound(Hdr, 2)).Value = Hdr
        .Offset(1).Resize(n, UBound(ka, 2)).Value2 = k
        Set lstObj = .Parent.ListObjects.Add(1, .Resize(n + 1, UBound(k, 2)), , 1)
        lstObj.Name = strLstName
    End With
End Sub

 

[ParanoidAndroid]

ok..will give it a try after the ester break...Wedneday. Fingers crossed.