Solved: duplicate record count and paste in new sheet

[sarat]

Hello Everyone

In my sheet 'Child', I want to check records for columns (AA, BB, CC, EE and FF) and if found duplicate record, then that will be counted into single record.
After that I have to reflect those record with count (as separte column 'F') along with distinct recrords with a total by creating new 'Master' excel file. (in the spreadsheet)

Before that, I want to convert the string from CC into numeric format like below (0 = Not treated, 1 = Treated, -1=Blank)

Any help is appreciated!

[Bob Phillips]

Sub SummariseData()
Dim lastrow As Long
Dim rng As Range

Application.ScreenUpdating = False

Worksheets("Child").Copy After:=Worksheets(Worksheets.Count)

With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("G1").Value = "COUNT"
.Range("G2").Resize(lastrow - 1).FormulaR1C1 = _
"=SUMPRODUCT(--(RC[-6]=C[-6]),--(RC[-5]=C[-5]),--(RC[-4]=C[-4]),--(RC[-3]=C[-3]),--(RC[-2]=C[-2]),--(RC[-1]=C[-1]))"
.Columns("G").Value = .Columns("G").Value
.Range("H2").Resize(lastrow - 1).FormulaR1C1 = _
"=SUMPRODUCT(--(RC[-7]=R2C[-7]:RC[-7]),--(RC[-5]=R2C[-5]:RC[-5]),--(RC[-4]=R2C[-4]:RC[-4]),--(RC[-3]=R2C[-3]:RC[-3]),--(RC[-2]=R2C[-2]:RC[-2]),--(RC[-6]=R2C[-6]:RC[-6]))"
.Rows("1:1").Insert Shift:=xlDown
.Range("H1").Value = "Temp"
.Range("H2").Value = 1
Set rng = .Range("H1").Resize(lastrow + 1)
rng.AutoFilter Field:=1, Criteria1:="<>1"
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
.Columns("H:H").Delete Shift:=xlToLeft
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("C2").Resize(lastrow - 1).Replace What:="Not treated", _
Replacement:="0"
.Range("C2").Resize(lastrow - 1).Replace What:="Treated", _
Replacement:="1"
.Range("C2").Resize(lastrow - 1).Replace What:="", _
Replacement:="-1"
End With

Application.ScreenUpdating = True
End Sub

[sarat]

Thanks xld for looking into the macro.
But I am not getting exact data in attached sheet. Could you please spend few minute to check it once again.

[Bob Phillips]

You will need to tell me what is wrong and why, I am not going to spend my time trying to figure it out.

[sarat]

Hello Xld,
Thanks for your quick response.
My requirement is to count the duplicate records (if it matches in AA, BB, CC, EE and FF columns). and print it in other sheet along with distinct records.(non-duplicate).
If we have a look on the data in sheet, total 603 records are there in sheet "child". When the macro runs, count is not matching (only 6 records displayed).

I want the summary report from sheet 'Child' where duplicate records merged into single records (if three duplicate records there , then output will be single record but count should be 3) along with all distinct records so that the count will match in both sheet.


e.g.



AA BB CC DD EE FF GG
3 0 Tranquilizer 2 HCP Pfizer
3 0 Tranquilizer 1 HCP Pfizer
3 0 Tranquilizer 1 HCP Pfizer


Output should be
AA BB CC EE FF COUNT
3 0 -1 2 HCP 1
3 0 -1 1 HCP 2

n:b: Output should be displayed like in master sheet

Thanks once again for your support

[CatDaddy]

the -1 was not in your original specifications...are there more cases than just 1 and 0?

[sarat]

Dear Catdaddy,
Please check the first specification where I have mention that for column CC, three different strings ( like treated, untreated etc) are there which I want to convert to numeric one and then start the above process

Before that, I want to convert the string from CC into numeric format like below (0 = Not treated, 1 = Treated, -1=Blank)

[Bob Phillips]

The autofilter threw my code

Sub SummariseData()
Dim lastrow As Long
Dim rng As Range

Application.ScreenUpdating = False

Worksheets("Child").Copy After:=Worksheets(Worksheets.Count)

With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(1).AutoFilter
.Range("G1").Value = "COUNT"
.Range("G2").Resize(lastrow - 1).FormulaR1C1 = _
"=SUMPRODUCT(--(RC[-6]=C[-6]),--(RC[-5]=C[-5]),--(RC[-4]=C[-4]),--(RC[-3]=C[-3]),--(RC[-2]=C[-2]),--(RC[-1]=C[-1]))"
.Columns("G").Value = .Columns("G").Value
.Range("H2").Resize(lastrow - 1).FormulaR1C1 = _
"=SUMPRODUCT(--(RC[-7]=R2C[-7]:RC[-7]),--(RC[-5]=R2C[-5]:RC[-5]),--(RC[-4]=R2C[-4]:RC[-4]),--(RC[-3]=R2C[-3]:RC[-3]),--(RC[-2]=R2C[-2]:RC[-2]),--(RC[-6]=R2C[-6]:RC[-6]))"
.Rows("1:1").Insert Shift:=xlDown
.Range("A1:H1").Value = "Temp"
.Range("H2").Value = 1
Set rng = .Range("H1").Resize(lastrow + 1)
rng.AutoFilter Field:=1, Criteria1:="<>1"
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
.Columns("H:H").Delete Shift:=xlToLeft
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("C2").Resize(lastrow - 1).Replace What:="Not treated", _
Replacement:="0"
.Range("C2").Resize(lastrow - 1).Replace What:="Treated", _
Replacement:="1"
.Range("C2").Resize(lastrow - 1).Replace What:="", _
Replacement:="-1"
End With

Application.ScreenUpdating = True
End Sub

[sarat]

Thank you very much. Its working very fine.
One simple doubt. In that macro, is it possible to exclude column D (with data like Tranquilizer, Viagra etc) and print only data for column AA, BB, CC, EE, FF and COUNT.
Can we print the output directly into sheet "Master" from A5 onwards by deleting old data if exists

Sorry to ask you once again as I am new.

[CatDaddy]

http://www.rondebruin.nl/print.htm

[Bob Phillips]

Public Sub SummariseData()
Dim lastrow As Long
Dim rng As Range

Application.ScreenUpdating = False

Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Master").Delete
Worksheets("Child").Copy Before:=Worksheets(1)
Application.DisplayAlerts = True

With ActiveSheet

.Name = "Master"

.Rows(1).AutoFilter

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("G1").Value = "COUNT"
.Range("G2").Resize(lastrow - 1).FormulaR1C1 = _
"=SUMPRODUCT(--(RC[-6]=C[-6]),--(RC[-5]=C[-5]),--(RC[-4]=C[-4]),--(RC[-2]=C[-2]),--(RC[-1]=C[-1]))"
.Columns("G").Value = .Columns("G").Value
.Range("H2").Resize(lastrow - 1).FormulaR1C1 = _
"=SUMPRODUCT(--(RC[-7]=R2C[-7]:RC[-7]),--(RC[-6]=R2C[-6]:RC[-6]),--(RC[-5]=R2C[-5]:RC[-5]),--(RC[-3]=R2C[-3]:RC[-3]),--(RC[-2]=R2C[-2]:RC[-2]))"
.Rows("1:1").Insert Shift:=xlDown
.Range("H1").Value = "Temp"
.Range("H2").Value = 1
Set rng = .Range("H1").Resize(lastrow + 1)
rng.AutoFilter Field:=1, Criteria1:="<>1"
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
.Columns("H:H").Delete Shift:=xlToLeft

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A1").Resize(lastrow, 7).Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
With .Range("C2").Resize(lastrow - 1)

.Replace What:="Not treated", Replacement:="0"
.Replace What:="Treated", Replacement:="1"
.Replace What:="", Replacement:="-1"
End With
With .Cells(lastrow + 1, "A")

.Value = "Total"
.Offset(0, 6).Formula = "=SUM(G2:G" & lastrow & ")"
With .Resize(1, 7)

.Font.Bold = True
.Interior.ColorIndex = .Parent.Range("A1").Interior.ColorIndex
End With

With .Offset(5, 0)

.Value = "cc"
.Font.Bold = True
.Interior.ColorIndex = .Parent.Range("A1").Interior.ColorIndex
.Offset(0, 1).Value = "0=Not treated"
.Offset(1, 1).Value = "1=Treated"
.Offset(2, 1).Value = "-1=Blank"
End With
End With
.Rows("1:3").Insert
.Range("A1").Value = "Report for Pfizer, Astrazeneca, Merck and Johnson"
.Range("A4").Copy
.Range("A1:C1").PasteSpecial Paste:=xlPasteFormats

.Columns("D").Delete
End With

Application.ScreenUpdating = True
End Sub

[sarat]

thanks XLD, Really appreciated:bow: :rotlaugh: