macros to find duplicates count in new sheet

Rmrekoj · Dec 7th 2018

I am trying to find the number of same values are repeated in particular column. Then I need to paste the value and the count of the repeated value in column A,B,C,D of another sheet. I need to count the number of times repeated values: data is like below... [TABLE="border: 0, cellpadding: 0, cellspacing: 0, width: 179"]

[tr]

[td]

Data1

[/td]

[td]

Data2

[/td]

[td]

Data3

[/td]

[td]

Data4

[/td]

[/tr]

[tr]

[td]

D1

[/td]

[td]

D3

[/td]

[td]

D1

[/td]

[td]

D1

[/td]

[/tr]

[tr]

[td]

D1

[/td]

[td]

D3

[/td]

[td]

D1

[/td]

[td]

D1

[/td]

[/tr]

[tr]

[td]

D1

[/td]

[td]

D2

[/td]

[td]

D1

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

D2

[/td]

[td]

D2

[/td]

[td]

D3

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

D2

[/td]

[td]

D3

[/td]

[td]

D2

[/td]

[td]

D5

[/td]

[/tr]

[tr]

[td]

D3

[/td]

[td]

D1

[/td]

[td]

D1

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

D3

[/td]

[td]

D2

[/td]

[td]

D1

[/td]

[td]

D1

[/td]

[/tr]

[tr]

[td]

D3

[/td]

[td]

D2

[/td]

[td]

D1

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

D3

[/td]

[td]

D3

[/td]

[td]

D3

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

D3

[/td]

[td]

D3

[/td]

[td]

D1

[/td]

[td]

D3

[/td]

[/tr]

[/TABLE]

and result should get like below [TABLE="border: 0, cellpadding: 0, cellspacing: 0, width: 227"]

[tr]

[td]

Data

[/td]

[td]

Count1

[/td]

[td]

Count1

[/td]

[td]

Count3

[/td]

[td]

Count4

[/td]

[/tr]

[tr]

[td]

D1

[/td]

[td]

3

[/td]

[td]

1

[/td]

[td]

7

[/td]

[td]

3

[/td]

[/tr]

[tr]

[td]

D2

[/td]

[td]

2

[/td]

[td]

4

[/td]

[td]

1

[/td]

[td]

0

[/td]

[/tr]

[tr]

[td]

D3

[/td]

[td]

5

[/td]

[td]

5

[/td]

[td]

2

[/td]

[td]

6

[/td]

[/tr]

[tr]

[td]

D5

[/td]

[td]

0

[/td]

[td]

0

[/td]

[td]

0

[/td]

[td]

1

[/td]

[/tr]

[/TABLE]

graha_karya · Dec 7th 2018

Perhab like this

Code

Sub test()
Dim r as range,e as range,dic as object,i&
set r = sheet1.[a1].currentRegion.offset(1)
set dic = createObject("scripting.dictionary")
for  each e in r
 dic(e.value) = ""
next e


with sheets.add
  .[a1].resize(dic.count) = application.transpose(dic.keys)
 for i = 2 to ubound(r.columns.
count)
      .parent.range(r.address).columns(i).formula = "=countif(" & r.columns(i).address & "," & .cells(1,1).address & ")"
next i
end with
end sub

Display More

Rmrekoj · Dec 7th 2018

hi Senior ,

thanks for the help but m facing the compile error####

graha_karya · Dec 7th 2018

Try again untest

Code

Sub test()
Dim r as range,e as range,dic as object,i&
set r = sheet1.[a1].currentRegion.offset(1)
set dic = createObject("scripting.dictionary")
 for each e in r
    dic(e.value) = ""
next e
 with sheets.add  
    .[a1].resize(dic.count) = application.transpose(dic.keys)
       for i = 1 to 4  
           .columns(i+1).formula = "=countif(" & r.columns(i).address & "," & .cells(1,1).address & ")"
       next i
   end with
end sub

Display More

Rmrekoj · Dec 7th 2018

Hi Dude,

after run above the above macro excel get crashed..
after several minutes finally in my hand got the 0 count
[TABLE="border: 0, cellpadding: 0, cellspacing: 0, width: 240"]

[tr]

[TD="width: 64, bgcolor: transparent"]D1[/TD]
[TD="width: 64, bgcolor: transparent, align: right"]0[/TD]
[TD="width: 64, bgcolor: transparent, align: right"]0[/TD]
[TD="width: 64, bgcolor: transparent, align: right"]0[/TD]
[TD="width: 64, bgcolor: transparent, align: right"]0[/TD]

[/tr]

[tr]

[TD="bgcolor: transparent"]D3[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]

[/tr]

[tr]

[TD="bgcolor: transparent"]D2[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]

[/tr]

[tr]

[TD="bgcolor: transparent"]D5[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]
[TD="bgcolor: transparent, align: right"]0[/TD]

[/tr]

[/TABLE]

and the formula pasted till row (1048576)..

Rmrekoj · Dec 7th 2018

I found the below function on other forum.. but it working only for the a single column ..
please can you work on it and take all our 4 column in data and result as we want

also if possible each criteria count and data name can I have In variable like ...below

dim strm1,strm2,strm3,strm4 as string
dim vlu1, vlu2,vlu3......till vlu16 as long

so I can position them as I want..

thanks for your help...

Sub naya()

Summarize Sheet1.Range("A2:A9"), Sheet1.Range("C1")

End Sub

Function Summarize(rngSource As Range, rngTarget As Range)

Dim rng As Range
Dim var As Variant
Set d = CreateObject("Scripting.Dictionary")
For Each rng In rngSource
If rng <> "" Then
If d.Exists(rng.Value) Then
d(rng.Value) = d(rng.Value) + 1
Else
d.Add rng.Value, 1
End If
End If
Next rng

rngTarget = "Value"
rngTarget.Offset(, 1) = "Count"
Set rng = rngTarget.Offset(1)
For Each var In d.Keys
rng = var
rng.Offset(, 1) = d(var)
Set rng = rng.Offset(1)
Next
End Function

Rmrekoj · Dec 7th 2018

yes dude appreciate....awesome your work.. .huge clap for you....

just final request can I get all output into variable, as m working on a project so I can store the value each criteria each position where I want.....

Rmrekoj · Dec 7th 2018

Plz updat sir...

graha_karya · Dec 7th 2018

Rmrekoj try this i am has test and work

Code

Sub test()
Dim r As Range, e As Range, dic As Object, i&
Set r = Sheet1.[a1].CurrentRegion
Set dic = CreateObject("system.collections.arraylist")
 For Each e In r
    If ((e.Value Like "D*") * (Not dic.contains(e.Value))) Then dic.Add e.Value
 Next e
 dic.Sort
     With [a21]
        .Resize(dic.Count) = Application.Transpose(dic.toarray)
       For i = 1 To 4
           .Offset(, i).Resize(dic.Count).Formula = "=countif(" & r.Columns(i).Address(True, True) & "," & .Cells(1, 1).Address(False, False) & ")"
       Next i
      End With
End Sub

Display More

graha_karya · Dec 7th 2018

and if you want to another sheet

Code

Sub test()
Dim r As Range, e As Range, dic As Object, i&
Set r = Sheet1.[a1].CurrentRegion
Set dic = CreateObject("system.collections.arraylist")
 For Each e In r
    If ((e.Value Like "D*") * (Not dic.contains(e.Value))) Then dic.Add e.Value
 Next e
 dic.Sort
     With Sheets.Add.[a5]
        .Resize(dic.Count) = Application.Transpose(dic.toarray)
       For i = 1 To 4
           .Offset(, i).Resize(dic.Count).Formula = "=countif('" & Sheet1.Name & "'!" & r.Columns(i).Address & "," & .Cells(1, 1).Address(False, False) & ")"
       Next i
      End With
End Sub

Display More

Rmrekoj · Dec 8th 2018

Thank you,, It was really helpful to have your input...I’m extremely fortunate to have you all guys as a master...

Rmrekoj · Dec 8th 2018

Quote from Carim

Thanks for your Thanks ..AND for the Like... :smile:

with the help of your vba I got new challenge below m working on that ,,...

Data is like ....date column will be filtered many criteria I have done work on that I just wanted to work after special cells

this is filtered data with some criteria and visible like below
[TABLE="border: 0, cellpadding: 0, cellspacing: 0, width: 164"]

[tr]

[td]

Date

[/td]

[td]

Data1

[/td]

[td]

Data2

[/td]

[/tr]

[tr]

[td]

A

[/td]

[td]

D1

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

B

[/td]

[td]

D1

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

B

[/td]

[td]

D1

[/td]

[td]

D2

[/td]

[/tr]

[tr]

[td]

A

[/td]

[td]

D2

[/td]

[td]

D2

[/td]

[/tr]

[tr]

[td]

B

[/td]

[td]

D2

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

A

[/td]

[td]

D3

[/td]

[td]

D1

[/td]

[/tr]

[tr]

[td]

A

[/td]

[td]

D3

[/td]

[td]

D2

[/td]

[/tr]

[tr]

[td]

B

[/td]

[td]

D3

[/td]

[td]

D2

[/td]

[/tr]

[tr]

[td]

A

[/td]

[td]

D3

[/td]

[td]

D3

[/td]

[/tr]

[tr]

[td]

B

[/td]

[td]

D3

[/td]

[td]

D3

[/td]

[/tr]

[/TABLE]

and output need

[TABLE="border: 0, cellpadding: 0, cellspacing: 0, width: 229"]

[tr]

[td][/td]

[td]

A

[/td]

[td][/td]

[td]

B

[/td]

[td][/td]

[/tr]

[tr]

[td]

Unique

[/td]

[td]

Col1

[/td]

[td]

Col2

[/td]

[td][/td]

[td]

Col1

[/td]

[td]

Col2

[/td]

[/tr]

[tr]

[td]

D1

[/td]

[td]

1

[/td]

[td]

1

[/td]

[td][/td]

[td]

2

[/td]

[td]

0

[/td]

[/tr]

[tr]

[td]

D3

[/td]

[td]

1

[/td]

[td]

2

[/td]

[td][/td]

[td]

1

[/td]

[td]

3

[/td]

[/tr]

[tr]

[td]

D2

[/td]

[td]

3

[/td]

[td]

2

[/td]

[td][/td]

[td]

2

[/td]

[td]

2

[/td]

[/tr]

[/TABLE]

Rmrekoj · Dec 10th 2018

Hi Sir, any solution for above m not able to do still working on that

Rmrekoj · Dec 11th 2018

Quote from Rmrekoj

Hi Sir, any solution for above m not able to do still working on that

?

Rmrekoj · Dec 11th 2018

Hi Sir, are you workin gon that ?

edulofter · Dec 13th 2018

Quote from graha_karya

and if you want to another sheet

Code

Sub test()
Dim r As Range, e As Range, dic As Object, i&
Set r = Sheet1.[a1].CurrentRegion
Set dic = CreateObject("system.collections.arraylist")
For Each e In r
If ((e.Value Like "D*") * (Not dic.contains(e.Value))) Then dic.Add e.Value
Next e
dic.Sort
With Sheets.Add.[a5]
.Resize(dic.Count) = Application.Transpose(dic.toarray)
For i = 1 To 4
.Offset(, i).Resize(dic.Count).Formula = "=countif('" & Sheet1.Name & "'!" & r.Columns(i).Address & "," & .Cells(1, 1).Address(False, False) & ")"
Next i
End With
End Sub

Display More

thanks for answer.
I learn it

Rmrekoj · Dec 15th 2018

Hi Team

Rmrekoj · Dec 15th 2018

Hi team,

this is working in excel how to use in vba

=SUMPRODUCT(SUBTOTAL(3,OFFSET(B2:B50,ROW(B2:B50)-MIN(ROW(B2:B50)),,1))*(B2:B50="A1"))

Thanks

Rmrekoj · Dec 17th 2018

HI team,

do u know how to add this in vba

graha_karya · Dec 17th 2018

if you want new case should be make new treat
try this and if this you want

Code

Sub test1()
Dim x, dic As Object, k, i&, cl&
x = Sheet9.[a1].CurrentRegion.Value
Set dic = CreateObject("scripting.dictionary")
Dim dic1 As Object, dic2 As Object
Set dic1 = CreateObject("scripting.dictionary")
    For i = 2 To UBound(x)
      If Not dic.exists(x(i, 1)) Then
         Set dic(x(i, 1)) = CreateObject("scripting.dictionary")
      End If
      dic(x(i, 1))(x(i, 2)) = dic(x(i, 1))(x(i, 2)) + 1
    Next i
    For i = 2 To UBound(x)
      If Not dic1.exists(x(i, 1)) Then
         Set dic1(x(i, 1)) = CreateObject("scripting.dictionary")
      End If
      dic1(x(i, 1))(x(i, 3)) = dic1(x(i, 1))(x(i, 3)) + 1
    Next i
Dim z()
ReDim z(1 To dic.Count + 10, 1 To 6)
 z(1, 2) = dic.keys()(0): z(1, 5) = dic.keys()(1)
 z(2, 1) = "Unique": z(2, 2) = "Col1": z(2, 3) = "Col2": z(2, 4) = "": z(2, 5) = "col1": z(2, 6) = "col2"
 For i = 0 To dic.Count - 1
      n = 3
      For Each k In dic(dic.keys()(i))
        z(n, 1) = k
        z(n, 2) = dic(z(1, 2)).Item(z(n, 1))
        z(n, 3) = dic1(z(1, 2)).Item(z(n, 1))
        z(n, 5) = dic(z(1, 5)).Item(z(n, 1))
        z(n, 6) = dic1(z(1, 5)).Item(z(n, 1))
        If z(n, 6) = "" Then z(n, 6) = 0
        n = n + 1
      Next k
 Next i
With Sheet9.[a26]
  .ClearContents
  .Resize(UBound(z), UBound(z, 2)) = z
End With
End Sub

Display More

macros to find duplicates count in new sheet

Participate now!

Share