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]

 

[Joe4]

Here is one way. I tried to document the code so you can see what is going on.

Sub MyMacro()

    Dim lastRow As Long
    Dim r As Long
    Dim lastCol As Long
    Dim c As Long
    Dim myRange As Range
    Dim myVal
    
    Application.ScreenUpdating = False
    
'   Find last row on workbook
    lastRow = Range("A1").SpecialCells(xlLastCell).Row
    
'   Loop through all rows, starting on row 1
    For r = 1 To lastRow
'       Find last column in that row
        lastCol = Cells(r, Columns.Count).End(xlToLeft).Column
'       Loop through all columns backwards
        For c = lastCol To 1 Step -1
'           Get cell value
            myVal = Cells(r, c)
            Select Case myVal
'               Remove blanks
                Case ""
                    Cells(r, c).Delete Shift:=xlToLeft
                Case Else
'                   Remove duplicates
                    If c > 1 Then
                        Set myRange = Range(Cells(r, 1), Cells(r, c - 1))
                        If Application.WorksheetFunction.CountIf(myRange, myVal) > 0 Then
                            Cells(r, c).Delete Shift:=xlToLeft
                        End If
                    End If
            End Select
        Next c
    Next r
    
    Application.ScreenUpdating = True
    
End Sub

 

[Ron99]

Thank you Joe...That's simply amazing!! It worked...

 

[Joe4]

You are welcome!

 

[Ron99]

Hello Joe,

I would require one last Macro if that's feasible. After deleting the blanks and the duplicate I have the below table now

data -

[TABLE="width: 256"]
<tbody>[TR]
[TD="width: 64, bgcolor: transparent"]A
[/TD]
[TD="width: 64, bgcolor: transparent"]B
[/TD]
[TD="width: 64, bgcolor: transparent"]C
[/TD]
[TD="width: 64, bgcolor: transparent"]D
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]B
[/TD]
[TD="bgcolor: transparent"]F
[/TD]
[TD="bgcolor: transparent"]G
[/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]H
[/TD]
[TD="bgcolor: transparent"]I
[/TD]
[TD="bgcolor: transparent"]D
[/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]K
[/TD]
[TD="bgcolor: transparent"]L
[/TD]
[TD="bgcolor: transparent"]M
[/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]N
[/TD]
[TD="bgcolor: transparent"]K
[/TD]
[TD="bgcolor: transparent"]P
[/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
</tbody>[/TABLE]

Output required is as below - macro has to check from each row if the same item has been repeated elsewhere in the data and bring the remaining data in the one row


[TABLE="width: 512"]
<tbody>[TR]
[TD="width: 64, bgcolor: transparent"]A
[/TD]
[TD="width: 64, bgcolor: transparent"]B
[/TD]
[TD="width: 64, bgcolor: transparent"]C
[/TD]
[TD="width: 64, bgcolor: transparent"]D
[/TD]
[TD="width: 64, bgcolor: transparent"]F
[/TD]
[TD="width: 64, bgcolor: transparent"]G
[/TD]
[TD="width: 64, bgcolor: transparent"]H
[/TD]
[TD="width: 64, bgcolor: transparent"]I
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]K
[/TD]
[TD="bgcolor: transparent"]L
[/TD]
[TD="bgcolor: transparent"]M
[/TD]
[TD="bgcolor: transparent"]N
[/TD]
[TD="bgcolor: transparent"]P
[/TD]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent"][/TD]
[TD="bgcolor: transparent"][/TD]
[/TR]
</tbody>[/TABLE]

 

[Fluff]

How about

Sub CopyDatatoOneRow()

   Dim Ary As Variant
   Dim Rw As Long
   Dim Col As Long
   
   Ary = Range("A1").CurrentRegion
   
   With CreateObject("scripting.dictionary")
      For Col = 1 To UBound(Ary, 2)
         For Rw = 1 To UBound(Ary, 1)
            If Not Ary(Rw, Col) = "" And Not .exists(Ary(Rw, Col)) Then .Add Ary(Rw, Col), Nothing
         Next Rw
      Next Col
      Sheets("[COLOR=#ff0000]Test1[/COLOR]").Range("A1").Resize(, .Count).Value = .keys
   End With
End Sub

This runs on the active sheet & will put the results on a sheet called Test1.
It assumes that you will never have more than 16,384 values

 

[Ron99]

Hello Joe,

I got an error message

Runtime Error 450 ( Wrong number of arguments or invalid property assignment.

 

[Fluff]

As you originally said that Joe4's code worked, I guessing that post#7 was aimed at me.
What line of code gave the error?

 

[Ron99]

Hello,


Sorry about that, I dint notice.


I re-run the code and it did run without any error but I did not get the desired output, will try to breakdown my requirement


1st row has 4 letters A,B,C,D.Code should search for each duplicate letter starting from the 1st row in the entire database and if any duplicates found then it should bring up the adjacent letters from that row to the 1st row.


A B C D
B F G
H I D
K L M
N K P


Once the 1st row search is complete from the above data the output should be


A B C D F G H I


Whereas for the below data these letters were not found in the 1st row, so the code should delete row 2 & row 3 and create new row2


K L M
N k P


Output should be


K L M N P


final output will be


A B C D F G H I
K L M N P

 

[Fluff]

If you had something like this

Excel 2013 32 bit
	A	B	C	D
1	A	B	C	D
2	B	F	G
3	H	I	D
4	K	L	F
5	N	K	P
Data

Would you expect row 4 to be copied to row 1 as the F matches & then row 5 to also be copied as the K matches?