Remove Duplicates from Column B keep other column cell values in same position

anu_gv

Board Regular
Joined
Sep 11, 2015
Messages
62
Hello All,
I am trying to find solution for my problem. Searched into this forum for Duplicates topic, no luck for my problem.
I have sheet contains the below info as Table 1 (this is just an example, I have 3000 rows and 15 columns in my sheet). I am looking for Outcome 1 and 2 as example below. Any help is really appreciated.
For outcome 1, I have tried removing the duplicates from column <Header 1> it removes everything and keep unique value as one set. I don't want that result i would like to keep the position in same place after removing the duplicates, i don't know how to do it.
For outcome 2, I have tried to looking to vlookup and hlookup option, it did not worked out.

Table 1:
Header 1Header 2 (Parameters)Header 3 (1M)Header 4 (6M)Header 5 (12M)Header 6 (24M)
Patient 1Wt505575100
Patient 1Length9095110140
Patient 1Blood Test+ve+ve-ve-ve
Patient 2Wt40507590
Patient 2Blood Test+ve+ve-ve-ve
Patient 3Wt50607095
Patient 3Length808590105
Patient 3Cholesterol10mg/dl15mg/dl20mg/dl30mg/dl
Patient 3Blood Test+ve+ve+ve-ve

[Outcome 1] in one sheet:
Remove the duplicates from <Header 1> Column and keep only one row.
Header 1
Header 2 (Parameters)Header 3 (1M)Header 4 (6M)Header 5 (12M)Header 6 (24M)
Patient 1Wt505575100
Length9095110140
Blood Test+ve+ve-ve-ve
Patient 2Wt40507590
Blood Test+ve+ve-ve-ve
Patient 3Wt50607095
Length808590105
Cholesterol10mg/dl15mg/dl20mg/dl30mg/dl
Blood Test+ve+ve+ve-ve

[Outcome 2] in 2nd sheet: No. of test completed for patients.

Patient 1Patient 2Patient 3
WtWtWt
LengthLength
Blood TestBlood TestBlood Test
Cholesterol

Thx
Anu
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

anu_gv

Board Regular
Joined
Sep 11, 2015
Messages
62
Hello All,

I have searched in google and found this Macro, I have tried, it did not work.

Sub Duplicates()
Dim N As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = N To 2 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Cells(i, 1) = ""
End If
Next i
End Sub

Let me know if there is anything i need to tweak on this macro.

Thx
Anu
 

BobUmlas

Well-known Member
Joined
Mar 14, 2002
Messages
1,181
You said column B. So you shoulld be looking at Cells(i,2)... not Cells(i,1)...
 

anu_gv

Board Regular
Joined
Sep 11, 2015
Messages
62
Yes, Bob. That is my typo in copying and pasting. I had correct macro in my sheet, it is not removing the duplicates..
Column A is basically numbers: 1,2,3,4........ etc.,
 

BobUmlas

Well-known Member
Joined
Mar 14, 2002
Messages
1,181

ADVERTISEMENT

You can enter the sequence 1,2,3... at an unused column.
Then sort everything by column B.
Then you an run your code.
Then Sort by the numbers you entered in the first step, restoring the original sequence.
That should do the job.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,622
Office Version
  1. 2007
Platform
  1. Windows
I recommend that you do not delete the duplicates, later you may have problems, to order or filter data, and others if you use other macros, which should consider those blanks.

Either way I give you the macro to remove duplicates and get Outcome 2.
Your data on Sheet1 starting in cell A1, Outcome 2 on Sheet2 in A1 onwards.

If you consider not removing duplicates, just remove this line from the macro:
Sheets("Sheet1").Range("A2").Resize(UBound(b)).Value = b

VBA Code:
Sub Remove_Duplicates()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic1 As Object, dic2 As Object
  Dim i As Long, j As Long, k As Long, lr As Long
  Dim m As Long, n As Long
  
  With Sheets("Sheet1")
    lr = .Range("A" & Rows.Count).End(3).Row
    a = .Range("A2:B" & lr).Value2
    m = Evaluate(Replace("=SUMPRODUCT((@<>"""")/COUNTIF(@,@&""""))", "@", .Name & "!A2:A" & lr)) 'unique patients
    n = Evaluate(Replace("=SUMPRODUCT((@<>"""")/COUNTIF(@,@&""""))", "@", .Name & "!B2:B" & lr)) 'unique param
  End With
  
  ReDim b(1 To UBound(a), 1 To 1)
  ReDim c(1 To n, 1 To m)
  Set dic1 = CreateObject("Scripting.dictionary")
  Set dic2 = CreateObject("Scripting.dictionary")
  
  For i = 1 To UBound(a)
    b(i, 1) = a(i, 1)
    If Not dic1.exists(a(i, 1)) Then
      j = j + 1
      dic1(a(i, 1)) = j     'column
    Else
      b(i, 1) = ""
    End If
    If Not dic2.exists(a(i, 2)) Then
      k = k + 1
      dic2(a(i, 2)) = k     'row
    End If
    c(dic2(a(i, 2)), dic1(a(i, 1))) = a(i, 2)
  Next
    
  Sheets("Sheet1").Range("A2").Resize(UBound(b)).Value = b
  With Sheets("Sheet2")
    .Cells.ClearContents
    .Range("A1").Resize(1, dic1.Count).Value = dic1.keys
    .Range("A2").Resize(k, j).Value = c
  End With
End Sub
 

anu_gv

Board Regular
Joined
Sep 11, 2015
Messages
62

ADVERTISEMENT

Hi Dante,
As you suggested I removed this line "Sheets("Sheet1").Range("A2").Resize(UBound(b)).Value = b" from Macro. I got the <Subscript out of range>.
Without removing this line, I ran the Macro I got the same error.
Not sure what is the error means....
Let me know the correction, I can correct it.

Thx
Anu.
 

anu_gv

Board Regular
Joined
Sep 11, 2015
Messages
62
You can enter the sequence 1,2,3... at an unused column.
Then sort everything by column B.
Then you an run your code.
Then Sort by the numbers you entered in the first step, restoring the original sequence.
That should do the job.
Hi Bob,
I am not clear on your suggestion. I don't have any unused column
Thanks.
Anu
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,622
Office Version
  1. 2007
Platform
  1. Windows
Change this line
ReDim c(1 To n, 1 To m)

For this
ReDim c(1 To n * m, 1 To m)
 

Watch MrExcel Video

Forum statistics

Threads
1,129,722
Messages
5,637,988
Members
416,997
Latest member
Beni Gal

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
Top