VBA code to search multiple columns and delete any duplicate cells (not rows)

[philmurp]

I have tried doing this with excel formulas but have reached a point where I dont think I can make it work. I am not experienced using VBA code so any help is really appreciated.

My Excel program (Excel 2010) currently has several columns and each column looks for and pulls data from a specific file on my computer. Then I need to delete any duplicate data entries, count the number of unique entries and track the changes through a chart. I have everything done except I cannot figure out (or find on the internet) a way to search in multiple columns (more than 2) and delete just the duplicate cells. I want to delete the cells in a way where there is one left. For example if the code 12gf is duplicated three time, I want to be left with one 12gf (it doesnt matter what column the original one is left in). Additionally, column length changes and they are not sorted. I have attempted to attach an image of an example file below. Thanks for all the help!


1.PNG

[k64]

Why can't you join the 3 columns into 1 and use remove duplicates?

[philmurp]

I could do that however, I want to do this automatically and I am not sure how to join the three columns. Online most ways are explained on how to merge columns, but I want to add them together and then check for duplicates. I want to be able to open my spreadsheet and look at my graphs and everything will update automatically. If anyone has a code to combine three columns and then remove duplicates automatically I am open to trying that for sure. Thanks!

[k64]

Yeah, there's definitely code to do that. Can you provide a sample workbook to use. I can't edit a picture

[philmurp]

Sure thing. An example is attached.

[k64]

Here, try this

Sub CombineRemoveDups()
Dim x As Long
Application.Calculation = xlCalculationManual
Sheets(2).Columns(1).Clear
With Sheets(1)
    For x = 1 To .UsedRange.Columns.Count
        Sheets(2).Range("A50000").End(xlUp).Offset(1).Resize(WorksheetFunction.CountA(.Columns(x))).Value = .Columns(x).Value
    Next x
End With
Sheets(2).Columns(1).RemoveDuplicates 1, xlNo
Application.Calculation = xlCalculationAutomatic
End Sub

[philmurp]

When I use the code with just the example I provided it works. However in my full document I have some other words in different cells and I keep getting an error when i try to use the code in my real workbook. I have attached my full example now. Sorry for not attaching it first, I didnt realize it was necessary that the labels be in the example.

[betatony]

so where is updated workbook?

[philmurp]

It is attached in my previous post, essentially I just added my labels back into the workbook where in the first workbook I posted I simplified it to much and just had my data in the document.

[k64]

Try this

Sub CombineRemoveDups()
Dim x As Long
Application.Calculation = xlCalculationManual
Sheets(2).Columns(1).Clear
With Sheets(1)
    For x = 1 To .UsedRange.Columns.Count
        Sheets(2).Range("A50000").End(xlUp).Offset(1).Resize(WorksheetFunction.CountA(.Columns(x))).Value = Range(.Cells(2, x), .Cells(50000, x).End(xlUp)).Value
    Next x
End With
Sheets(2).Columns(1).RemoveDuplicates 1, xlNo
Application.Calculation = xlCalculationAutomatic
End Sub

[philmurp]

That worked except that I got N/A in one cell, I am not sure why any ideas? Attached is my result:

[k64]

Yes. When I changed the range to account for the headers, I didn't change the resizing. This code should fix that

Sub CombineRemoveDups()
Dim x As Long
Application.Calculation = xlCalculationManual
Sheets(2).Columns(1).Clear
With Sheets(1)
    For x = 1 To .UsedRange.Columns.Count
        Sheets(2).Range("A50000").End(xlUp).Offset(1).Resize(WorksheetFunction.CountA(.Columns(x)) - 1).Value = Range(.Cells(2, x), .Cells(50000, x).End(xlUp)).Value
    Next x
End With
Sheets(2).Columns(1).RemoveDuplicates 1, xlNo
Application.Calculation = xlCalculationAutomatic
End Sub

[philmurp]

I am still getting this error:

Capture.PNG

Is this an issue of the naming of my sheets and location in the sheets of the data? For example, does this code work no matter where the columns are or do they have to be in the first three columns (a,b,c) etc... Thanks

[k64]

My code says to go to the first sheet and look in column1 through column(number of used columns on the sheet). So it is expecting the data to be in sheet 1 and in columns A:whatever. If your data is different, just change my code to match.

[philmurp]

That Worked thank you! Also, I may eventually track several sheets, is it possible to loop this code for as many sheets I have and just change the sheet name/columns etc within each loop?

So for example if I have sheets 1-3 with my data I want to run this code one time and within the code if will look in each sheet and populate sheet 4 with a column of data that has no duplicates.

Thanks for the help I will definitely leave a positive rep.

[k64]

Yes, just do this:

Sub CombineRemoveDups()
Dim x&, i As Long
Application.Calculation = xlCalculationManual
Sheets(Sheets.Count).Columns(1).Clear
For i = 1 To Sheets.Count - 1
    With Sheets(i)
        For x = 1 To .UsedRange.Columns.Count
            Sheets(Sheets.Count).Range("A50000").End(xlUp).Offset(1).Resize(WorksheetFunction.CountA(.Columns(x)) - 1).Value = Range(.Cells(2, x), .Cells(50000, x).End(xlUp)).Value
        Next x
    End With
Next i
Sheets(Sheets.Count).Columns(1).RemoveDuplicates 1, xlNo
Application.Calculation = xlCalculationAutomatic
End Sub

[philmurp]

I am getting the below error:

Capture.PNG

I also want it to come as each sheet having its own column so can I put the following inside the loop and change 1 to i?

[Sheets(Sheets.Count).Columns(i).RemoveDuplicates 1, xlNo]

[k64]

I can't see what error you're having. Yes, you can put it in the loop. It should look like this:

Sub CombineRemoveDups()
Dim x&, i As Long
Application.Calculation = xlCalculationManual
Sheets(Sheets.Count).Columns(1).Clear
For i = 1 To Sheets.Count - 1
    With Sheets(i)
        For x = 1 To .UsedRange.Columns.Count
            Sheets(Sheets.Count).Cells(50000, i).End(xlUp).Offset(1).Resize(WorksheetFunction.CountA(.Columns(x)) - 1).Value = Range(.Cells(2, x), .Cells(50000, x).End(xlUp)).Value
        Next x
    End With
    Sheets(Sheets.Count).Columns(i).RemoveDuplicates 1, xlNo
Next i
Application.Calculation = xlCalculationAutomatic
End Sub

[philmurp]

I am attaching an expanded example workbook, I would like one new sheet that has one column per sheet and those column each have that sheet's list of unique data entries within it

[k64]

Try this

Sub CombineRemoveDups()
Dim x&, i&, r As Long
Application.Calculation = xlCalculationManual
Sheets(Sheets.Count).Cells.Clear
For i = 1 To Sheets.Count - 1
    With Sheets(i)
        For x = 1 To .UsedRange.Columns.Count
            r = WorksheetFunction.CountA(.Columns(x)) - 1
            If r > 0 Then Sheets(Sheets.Count).Cells(50000, i).End(xlUp).Offset(1).Resize(r).Value = Range(.Cells(2, x), .Cells(50000, x).End(xlUp)).Value
        Next x
    End With
    Sheets(Sheets.Count).Columns(i).RemoveDuplicates 1, xlNo
Next i
Application.Calculation = xlCalculationAutomatic
End Sub

[philmurp]

Thats the one! Thanks a ton for your help, I should have thought of the expanded example first and saved us both some time, I learned for next time

[k64]

You're welcome. Glad I could help Yes, in general, try to make your samples as close to the real thing as possible.