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

[anu_gv]

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 1	Header 2 (Parameters)	Header 3 (1M)	Header 4 (6M)	Header 5 (12M)	Header 6 (24M)
Patient 1	Wt	50	55	75	100
Patient 1	Length	90	95	110	140
Patient 1	Blood Test	+ve	+ve	-ve	-ve
Patient 2	Wt	40	50	75	90
Patient 2	Blood Test	+ve	+ve	-ve	-ve
Patient 3	Wt	50	60	70	95
Patient 3	Length	80	85	90	105
Patient 3	Cholesterol	10mg/dl	15mg/dl	20mg/dl	30mg/dl
Patient 3	Blood 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 1	Wt	50	55	75	100
	Length	90	95	110	140
	Blood Test	+ve	+ve	-ve	-ve
Patient 2	Wt	40	50	75	90
	Blood Test	+ve	+ve	-ve	-ve
Patient 3	Wt	50	60	70	95
	Length	80	85	90	105
	Cholesterol	10mg/dl	15mg/dl	20mg/dl	30mg/dl
	Blood Test	+ve	+ve	+ve	-ve

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

Patient 1	Patient 2	Patient 3
Wt	Wt	Wt
Length		Length
Blood Test	Blood Test	Blood Test
		Cholesterol

Thx
Anu

 

[anu_gv]

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]

You said column B. So you shoulld be looking at Cells(i,2)... not Cells(i,1)...

 

[anu_gv]

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]

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]

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

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]

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]

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]

got the <Subscript out of range>.

Press debug button and tell me which line is highlighted.

 

[DanteAmor]

Change this line
ReDim c(1 To n, 1 To m)

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