• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

remove duplicates+blank cells from rows

meir

New Member
hello,

i need (i think) a vba solution to my problem,
from time to time i receive an excel file that contains phone numbers from a a company that collects phone numbers from multiple sources,the file is compiled of one column (A) that contains ID numbers (Thousands) and several (about 30) more columns that contains phone/blank cells that belongs to the specific ID in column A (each ID is in a row),because every column (except A) represent different source of information its very common for some cells to be blank or contain duplicated phones.
what i need is a vba code that removes blank and duplicated cells (leaves the unique number),and than move the remaining phones closer to the ID column.

i uploaded an example to what i want to achieve, the file contains 2 sheets (one for the raw data and one ("fixed") for what the solution need to look like).

thanks in advance,

meir
 

Attachments

  • Example.xlsx
    14 KB · Views: 15

Hi !

Your result worksheet seems to have errors !
For example in row #6, column V : it's not a duplicate !
So why this phone does not appear in result ? As others …
 
you are probably right,i did the removing and moving manually so i must have missed a few cells.
 
Check this..

Code:
Sub arrange_data()
Dim s As String, i As Integer, l As Integer, r As Range

With Range("A1").CurrentRegion
    With .Offset(, 1).Resize(, .Columns.Count - 1)
        For i = 1 To .Rows.Count - 1
            Set r = .Resize(1).Offset(i)
            s = Application.Trim(Join(Application.Transpose(Application.Transpose(r)), " "))
                l = Application.CountIf(r, "<>")
                    r.Cells.ClearContents
                        r.Item(1).Resize(, l) = Split(s)
        Next
    End With
End With
End Sub
 
According to initial attachment,
paste this demonstration to RAW DATA worksheet module :​
Code:
Sub Demo()
            Dim Rg As Range
            Application.ScreenUpdating = False
For R& = 2 To Me.UsedRange.Rows.Count
    Set Rg = Cells(R, 1).End(xlToRight)
        C& = Rg.Column
    Do
        Set Rg = Rg.End(xlToRight)
         If Rg.Value = "" Then
            Exit Do
         ElseIf IsError(Application.Match(Rg.Value, Cells(R, 2).Resize(, C - 1), 0)) Then
            C = C + 1
            Rg.Copy Cells(R, C)
         End If
            Rg.ClearContents
    Loop
Next
            Set Rg = Nothing
            Application.ScreenUpdating = True
End Sub
Do you like it ? So thanks to click on bottom right Like !
 
cant run the last code,it gives me "invalid use of me keyword" compile error.
Works like a breeze on my side, so it's your bad
'cause you didn't well paste code as written in my previous post !

Or replace Me by ActiveSheet
 
i replaced Me with ActiveSheet and it works as intended in the original example file,however, the code won't work if i copy other data into the original file or if i copy the code into a different file (the real file are a lot bigger than the example file).
 

As you pasted code, the data worksheet must be the active worksheet.

Or well read in my code post where to paste the procedure and apply …

 
Back
Top