Require macro

[Ron99]

Hello,
I need a macro to remove duplicates by row and also remove the blanks. Its a huge data by rows and columns
below example - duplicates "Rob & "goal" to be removed, but should retain unique and remove the blanks

[TABLE="width: 500"]
<tbody>[TR]
[TD]gulf[/TD]
[TD]Rob[/TD]
[TD][/TD]
[TD][/TD]
[TD]stat[/TD]
[TD]Rob[/TD]
[TD]aim[/TD]
[TD]hero[/TD]
[TD]fun[/TD]
[TD]goal[/TD]
[TD]view[/TD]
[TD]review[/TD]
[TD][/TD]
[TD]page[/TD]
[TD]goal[/TD]
[/TR]
</tbody>[/TABLE]


Output -


[TABLE="width: 500"]
<tbody>[TR]
[TD]gulf[/TD]
[TD]Rob[/TD]
[TD]stat[/TD]
[TD]aim[/TD]
[TD]hero[/TD]
[TD]fun[/TD]
[TD]goal[/TD]
[TD][/TD]
[TD]view[/TD]
[TD]review[/TD]
[TD]page[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[Ron99]

Yes, That's correct. Row 4 to be copied to row 1 and then row 5 to be copied to row 4.

 

[Fluff]

How about

Sub CopyDatatoOneRow()

   Dim Cl As Range

   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
      Next Cl
      For Each Cl In ActiveSheet.UsedRange.Offset(1).Resize(ActiveSheet.UsedRange.Rows.Count - 1)
         If .exists(Cl.Value) Then
            Cl.ClearContents
            Intersect(Cl.EntireRow, ActiveSheet.UsedRange).SpecialCells(xlConstants).Copy Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
            Cl.EntireRow.ClearContents
         End If
      Next Cl
      .removeall
   End With
   Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1").CurrentRegion.Offset(1)
         If Not Cl.Value = "" And Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
      Next Cl
      Range("A2").Resize(, .Count).Value = .keys
      Rows("3:1048576").Delete
   End With
         
End Sub

 

[Ron99]

Hello,

I run the code and got the error message

Run time error - 438

Object doesn't support this property or method.

 

[Fluff]

Which line of code gave that error?

 

[Ron99]

Hello,

Error is on this line

Range("A2").Resize(, .Count).Value = .keys

 

[Ron99]

Hello,

Any help on this error message.

Thanks,
Ron

 

[Fluff]

Have you changed the code at all?

 

[Ron99]

I did try changing to - Sheets("Test1").Range("A2").Resize(, .Count).Value = .keys. which did not help. I have a very limited knowledge with Macro, if you can assist that will be a great help.

This code - Sub CopyDatatoOneRow() works absolutely fine for the 1st row in the database but doesn't proceed further for the remaining rows.

Thank you.
Ron

 

[Fluff]

Could you supply a sample of the data when it's failing? As I cannot replicate the error.