How to find duplicated items???

[VN]

I would like to find items that may duplicate in my data.

My data have dimension WxLxH or LxWxH or HxWxL so I have to do some thing to separate the item that may be duplicated item.

How can I do?

(may be make a format color for duplicated items)

Exsample as below;

Book1
	C	D	E	F	G
17	Original Data				New Data
18	12x5x6 mm.				12x5x6 mm.
19	3*2*5.5 mm				3*2*5.5 mm
20	5mm x 77.3 x 8mm				5mm x 77.3 x 8mm
21	3 mm x 2mm x 5.5 mm	I would like it to be==>			3 mm x 2mm x 5.5 mm
22	12mm*5mm*6mm				6mm*12mm*5mm
23	12x5x6 mm.				5x6 x12mm.
24	3*2*5.5 mm				3*2*5.5 mm
25	5mm x 77.3 x 8mm				5mm x 77.3 x 8mm
26	4 mm x 2mm x 5.5 mm				4 mm x 2mm x 5.5 mm
27	12mm*5mm*6mm				12mm*5mm*6mm
28	12x5x6 mm.				12x5x6 mm.
29	3*2*5.5 mm				3*5.5*2 mm
30	5mm x 77.3 x 8mm				5mm x 77.3 x 8mm
31	5 mm x 2mm x 5.5 mm				5 mm x 2mm x 5.5 mm
32	12mm*5mm*6mm				12mm*5mm*6mm
Sheet1

 

[acw]

Hi

Easiest way I can see is to have all the measurements in the same format. The following UDF will generate a consistent approach. Put the code below into a general module associated with the sheet. Then

Function myfunc(xx)
  Dim myarr As Variant
  holder = xx
  holder = WorksheetFunction.Substitute(holder, "mm.", "")
  holder = WorksheetFunction.Substitute(holder, "mm", "")
  holder = WorksheetFunction.Substitute(holder, "*", ",")
  holder = WorksheetFunction.Substitute(holder, " ", "")
  holder = WorksheetFunction.Substitute(holder, "x", ",")
  myarr = Evaluate("={""" & WorksheetFunction.Substitute(holder, ",", """,""") & """}")
  For i = 1 To 3
    myarr(i) = Val(myarr(i))
  Next i
  For i = 1 To 2
    For j = 2 To 3
      If myarr(j) < myarr(i) Then
        tempp = myarr(i)
        myarr(i) = myarr(j)
        myarr(j) = tempp
      End If
    Next j
  Next i
  myfunc = myarr(1) & "x" & myarr(2) & "x" & myarr(3)
End Function

G18: =myfunc(C18)
H18: =IF(COUNTIF($G$18:G18,G18)>1,"DUPLICATE","")

Copy G18:H18 down as required.

HTH

Tony

 

[VN]

Thank you so much, Tony


I will try..


VN..

 

[VN]

Oh... in fact, some items of my data is not dimension LxWxH that may be OD 23xID 22 or 220 VAC * 15 amp * 2Poll *55 etc..


How can i do??

Thanks.

 

[acw]

added different code method

Hi

1) Is the separator always going to be x or * (ie 2x2x2 or 2*2*2)

2) Is the size always going to be 3 dimensions or can it be of variable number of dimensions.


Tony

Function myfunc2(xx)
  Dim myarr As Variant
  Set fs = CreateObject("vbscript.regexp")
  Set fs = New RegExp
  
  
  fs.Global = True
  fs.Pattern = "[^0-9*x.]"
  holder = fs.Replace(xx, "")
  fs.Pattern = "[x*]"
  holder = fs.Replace(holder, ",")
  If Right(holder, 1) = "." Then holder = Left(holder, Len(holder) - 1)
  myarr = Evaluate("={""" & WorksheetFunction.Substitute(holder, ",", """,""") & """}")
  For i = 1 To UBound(myarr)
    myarr(i) = Val(myarr(i))
  Next i
  For i = 1 To UBound(myarr) - 1
    For j = 2 To UBound(myarr)
      If myarr(j) < myarr(i) Then
        tempp = myarr(i)
        myarr(i) = myarr(j)
        myarr(j) = tempp
      End If
    Next j
  Next i
  
  myfunc2 = myarr(1) & "x" & myarr(2) & "x" & myarr(3)
  
  
End Function

 

[VN]

Thank you ,Tony

I found ERROR at New RegExp that " User-defined type not defined".

 

[acw]

VN

Sorry, that line should be commented out or removed. Not required. Comes from the playing I was doing when I created this second method.

How about the questions I asked?


Tony

 

[VN]

For ERROR .. I can use it aleady. Thank you for your advice.




Oh..Sorry for your question..
1. Yes .the separator always going to be * or x .

2. The size of dimensions is variable . Some Item is 2 ..some item 3 ..4…or 5 .

 

[acw]

VN

Ok try

Function myfunc2(xx)
  Dim myarr As Variant
  Set fs = CreateObject("vbscript.regexp")
  
  
  fs.Global = True
  fs.Pattern = "[^0-9*x.]"
  holder = fs.Replace(xx, "")
  fs.Pattern = "[x*]"
  holder = fs.Replace(holder, ",")
  If Right(holder, 1) = "." Then holder = Left(holder, Len(holder) - 1)
  myarr = Evaluate("={""" & WorksheetFunction.Substitute(holder, ",", """,""") & """}")
  For i = 1 To UBound(myarr)
    myarr(i) = Val(myarr(i))
  Next i
  For i = 1 To UBound(myarr) - 1
    For j = i + 1 To UBound(myarr)
      If myarr(j) < myarr(i) Then
        tempp = myarr(i)
        myarr(i) = myarr(j)
        myarr(j) = tempp
      End If
    Next j
  Next i
  holder = ""
  For i = LBound(myarr) To UBound(myarr)
    holder = holder & myarr(i) & "x"
  Next i
  myfunc2 = Left(holder, Len(holder) - 1)
  
  
End Function

Tony

 

[agihcam]

Hi -

I played around with this post and try if can be handled in one macro, I've come up with this codes;

Sub sample()
Dim i, ii As Long
Dim a
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 18 To Range("c" & Rows.Count).End(xlUp).Row
a = WorksheetFunction.Substitute(Cells(i, "c").Value, "mm.", "")
a = WorksheetFunction.Substitute(a, "mm", "")
a = WorksheetFunction.Substitute(a, "*", "x")
a = WorksheetFunction.Substitute(a, " ", "")
Cells(i, "g") = a
Next
Range("G18").Select
Range(Selection, Selection.End(xlDown)).Select
    Selection.TextToColumns Destination:=Range("G18"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=True, Comma:=True, Space:=True, Other:=True, OtherChar:= _
        "x", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))
For ii = 18 To Range("g" & Rows.Count).End(xlUp).Row
Range(Cells(ii, "g"), Cells(ii, "g").End(xlToRight)).Select
    Selection.Sort Key1:=Cells(ii, "g"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
Cells(ii, "g") = Cells(ii, "g") & "x" & Cells(ii, "h") & "x" & Cells(ii, "i") & "x" & Cells(ii, "j") & "x" & Cells(ii, "k") & "x" & Cells(ii, "l")
Next

i = Range("g" & Rows.Count).End(xlUp).Row
For ii = 18 To i
With Range("g18:g" & i)
Set c = .Find(Cells(ii, "g").Value, , , xlWhole)
If Not c Is Nothing And c.Address <> Cells(ii, "g").Address Then
firstAddress = c.Address
Do
c.Offset(, 6) = "Duplicate"
Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Next
Columns("h:l").Delete
i = Range("g" & Rows.Count).End(xlUp).Row
For ii = 18 To i
Cells(ii, "g") = Cells(ii, "c")
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub