Code Help -- Delete dups colunm to column per row

HowdeeDoodee

Well-known Member
Joined
Nov 15, 2004
Messages
599
I do not know where I got this code, probably here. The code deletes dups in each sekected row, going across, column to column for a few rows. However, I cannot get the code to work on a whole sheet. Can anyone change the code or give me new code to do what this code is supposed to do?

Example of what the code is supposed to do for the whole sheet:

Before:

Row1.....apple.....apple....pear....peach
Row2....people....cats....cats....apple
Row3....TV....radio....TV....car
Row4....car....nice....code....car

After:

Row1.....apple....pear....peach
Row2....people....cats....apple
Row3....TV....radio....car
Row4....car....nice....code


Code:
Sub RemoveDupsAcrossARowColumnByColumn()

'Remove Duplicates in Every row, going across, column to colunn

Dim Cell As Variant
Do Until ActiveCell = ""
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
For Each Cell In Selection
If WorksheetFunction.CountIf(Selection, Cell) > 1 Then
Cell.ClearContents
Else
End If
Next Cell
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
ActiveCell.Range("A2").Select
Loop
End Sub

Thank you in advance for any replies.
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Hi
try
Code:
Sub test()
Dim a, i As Long, ii As Long, result(), n As Long
a = Range("a1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a,1)
         For ii = 1 To UBound(a,2)
             If Not IsEmpty(a(i,ii)) And Not .exists(a(i,ii)) Then
                  n = n + 1
                  result(i,n) = a(i,ii)
                  .add a(i,ii), Nothing
             End If
         Next
         .removeall : n = 0
      Next
End With
Range("a1").CurrentRegion.Value = result
End Sub
 
Upvote 0
Jindon, I am getting a "Subscript out of range" error message.

The yellow line indicating the line of code with the problem points to this line...

result(i, n) = a(i, ii)

Can you fix?

Thank you again.
 
Upvote 0
Oops!
Missing very important line..
Code:
Sub test()
Dim a, i As Long, ii As Long, result(), n As Long
a = Range("a1").CurrentRegion.Value
ReDim result(1 To UBound(a,1), 1 To UBound(a,2))
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a,1)
         For ii = 1 To UBound(a,2)
             If Not IsEmpty(a(i,ii)) And Not .exists(a(i,ii)) Then
                  n = n + 1
                  result(i,n) = a(i,ii)
                  .add a(i,ii), Nothing
             End If
         Next
         .removeall : n = 0
      Next
End With
Range("a1").CurrentRegion.Value = result
End Sub
 
Upvote 0
Well, I think I need you to make the code ignore blank cells. My project is an outline placed on the sheet. I have an outline like this...

I. This is the first major line.
......A. This is a sub line of the first line.
......B. This is the second line under the first major line.
II. This is the second major line.
......A. This is a sub line of the second line.
............1. Facts are left out.
............2. All facts must be included
............3. Keep all things in mind
......B. This is a sub line of the second line under the first sub line

The indents in the outline above are really columns. The indents for the lines with A., B., 1., 2., 3., are blank cells. When I ran the new code, I think the new code considered all the blank cells as duplicates and destroyed my outline. So if you can make the code ignore the blank cells and remove only duplicate cells on each line that are filled duplicate cells we may have a final solution.

Thank you again Jindon.
 
Upvote 0
HowdeeDoodee
try this
Code:
Sub test()
Dim a, i As Long, ii As Long, result(), n As Long, t As Long
a = Range("a1").CurrentRegion.Value
ReDim result(1 To UBound(a,1), 1 To UBound(a,2))
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a,1)
         For ii = 1 To UBound(a,2)
             If Not IsEmpty(a(i,ii)) Then
                  n = ii
                  Do While ii + t <=UBound(a,2)
                       If Not IsEmpty(a(i,ii + t)) And Not .exists(a(i,ii + t)) Then
                            result(i,n) = a(i,ii + t)
                            .add a(i,ii + t), Nothing
                            n = n + 1
                       End If
                       t = t + 1
                   Loop
                   Exit For
              End If
         Next
         .removeall : n = 0
      Next
End With
Range("a1").CurrentRegion.Value = result
End Sub
Edit code 15:18 Tokyo Time
 
Upvote 0
Edited.

Jindon, the new code deletes all the contents in all the cells except cell A1.

Thank you again.

I tried to make an outline but the outline did not display properly on the screen. I had to delete it.
 
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,272
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top