Another Code Please!

Dazzawm

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,786
Office Version
  1. 365
Platform
  1. Windows
I need a code that when I select a column if a word i.e ABC or a number i.e 123 appears anywhere within a cell more than once I would like all duplicates removed just leaving the one.

e.g

Cell A1 Before

ABC 123 123 ABC ABC 456 DEF

Cell A1 After

ABC 123 456 DEF

and so on down every row until the last.

I will need to use this on more than one column so its best if the code works on the active column.

Thanks.
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
I think this macro does what you asked...
Code: 
Sub RemoveDuplicatesFromCells()
  Dim Cell As Range, CellText As String, OneWord As Variant, Words() As String, FirstOne As Long
  Const RemoveMe As String = "ABC,123"   'NOTE - no spaces around the commas
  Words = Split(RemoveMe, ",")
  For Each Cell In ActiveCell.EntireColumn.SpecialCells(xlCellTypeConstants)
    CellText = Cell.Value
    For Each OneWord In Words
      If InStr(CellText, OneWord) Then
        FirstOne = InStr(CellText, OneWord)
        CellText = Replace(CellText, OneWord, "")
        Cell.Value = WorksheetFunction.Trim(Left(CellText, FirstOne) & OneWord & Mid(CellText, FirstOne))
      End If
    Next
  Next
End Sub
 
Upvote 0
Sorry I selected a column and it did nothing.
 
Upvote 0
Hi,

Maybe this UDF

Code: 
Function noDups(t As String)
    Dim RegEx As Object, RegMatches As Object
    Dim RstStr As String, i As Long
    
    Set RegEx = CreateObject("VBScript.RegExp")
    
    With RegEx
        .MultiLine = False
        .IgnoreCase = True
        .Global = True
        .Pattern = "\b\w+\b"
        Set RegMatches = .Execute(t)
    End With
    
    For i = 0 To RegMatches.Count - 1
        If InStr(1, RstStr, RegMatches(i)) = 0 Then
            RstStr = RstStr & RegMatches(i) & " "
        End If
    Next i
    
    noDups = Trim(RstStr)
End Function

Usage
A B
<TABLE style="WIDTH: 288pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=383><COLGROUP><COL style="WIDTH: 173pt; mso-width-source: userset; mso-width-alt: 8411" width=230><COL style="WIDTH: 115pt; mso-width-source: userset; mso-width-alt: 5595" width=153><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 173pt; HEIGHT: 15pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=20 width=230>ABC 123 123 ABC ABC 456 DEF

</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 115pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" id=td_post_2783394 class=xl64 width=153>ABC 123 456 DEF</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64 height=20>234 nmn 12 12 VGTH VGTH 234</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64>234 nmn 12 VGTH</TD></TR></TBODY></TABLE>

Formula in B1
=noDups(A1)
copy down

HTH

M.
 
Upvote 0
Marcelo Branco said:
Hi,

Maybe this UDF

Code: 
Function noDups(t As String)
    Dim RegEx As Object, RegMatches As Object
    Dim RstStr As String, i As Long
 
    Set RegEx = CreateObject("VBScript.RegExp")
 
    With RegEx
        .MultiLine = False
        .IgnoreCase = True
        .Global = True
        .Pattern = "\b\w+\b"
        Set RegMatches = .Execute(t)
    End With
 
    For i = 0 To RegMatches.Count - 1
        If InStr(1, RstStr, RegMatches(i)) = 0 Then
            RstStr = RstStr & RegMatches(i) & " "
        End If
    Next i
 
    noDups = Trim(RstStr)
End Function

Usage
A B
<TABLE style="WIDTH: 288pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=383><COLGROUP><COL style="WIDTH: 173pt; mso-width-source: userset; mso-width-alt: 8411" width=230><COL style="WIDTH: 115pt; mso-width-source: userset; mso-width-alt: 5595" width=153><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 173pt; HEIGHT: 15pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=20 width=230>ABC 123 123 ABC ABC 456 DEF


</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 115pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" id=td_post_2783394 class=xl64 width=153>ABC 123 456 DEF</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64 height=20>234 nmn 12 12 VGTH VGTH 234</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64>234 nmn 12 VGTH</TD></TR></TBODY></TABLE>

Formula in B1
=noDups(A1)
copy down

HTH

M.
Click to expand...

Cant get that to work either
 
Upvote 0
dazwm said:
Sorry I selected a column and it did nothing.
Click to expand...
My code worked here using the data you posted and other similar data that I made up. My code is case sensitive... to you by any chance have non-upper case lettering in your cells for the words in my RemoveMe constant (in the Const statement) string? Since you cannot get the other submitted code to work either, I'm guessing there is something about your data which is different than your description of it would indicate. Any chance you can post your code for us?

You can post it online using one of these free posting websites...

Box: http://www.box.net/files
MediaFire: http://www.mediafire.com
FileFactory: http://www.filefactory.com
FileSavr: http://www.filesavr.com
FileDropper: http://www.filedropper.com
RapidShare: http://www.rapidshare.com

Then post the URL they give you for the file back here.
 
Upvote 0
Rick Rothstein said:
My code worked here using the data you posted and other similar data that I made up. My code is case sensitive... to you by any chance have non-upper case lettering in your cells for the words in my RemoveMe constant (in the Const statement) string? Since you cannot get the other submitted code to work either, I'm guessing there is something about your data which is different than your description of it would indicate. Any chance you can post your code for us?

You can post it online using one of these free posting websites...

Box: http://www.box.net/files
MediaFire: http://www.mediafire.com
FileFactory: http://www.filefactory.com
FileSavr: http://www.filesavr.com
FileDropper: http://www.filedropper.com
RapidShare: http://www.rapidshare.com

Then post the URL they give you for the file back here.
Click to expand...

Yes, some of the data is proper case, so I need the code to be non-case sensitive please. I cant really post the file as it is sensitive information, which is why I used ABC, 123 etc..
 
Last edited:
Upvote 0
Marcelo Branco said:
Hi,

Maybe this UDF

Code: 
Function noDups(t As String)
    Dim RegEx As Object, RegMatches As Object
    Dim RstStr As String, i As Long
 
    Set RegEx = CreateObject("VBScript.RegExp")
 
    With RegEx
        .MultiLine = False
        .IgnoreCase = True
        .Global = True
        .Pattern = "\b\w+\b"
        Set RegMatches = .Execute(t)
    End With
 
    For i = 0 To RegMatches.Count - 1
        If InStr(1, RstStr, RegMatches(i)) = 0 Then
            RstStr = RstStr & RegMatches(i) & " "
        End If
    Next i
 
    noDups = Trim(RstStr)
End Function

Usage
A B
<TABLE style="WIDTH: 288pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=383><COLGROUP><COL style="WIDTH: 173pt; mso-width-source: userset; mso-width-alt: 8411" width=230><COL style="WIDTH: 115pt; mso-width-source: userset; mso-width-alt: 5595" width=153><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 173pt; HEIGHT: 15pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=20 width=230>ABC 123 123 ABC ABC 456 DEF


</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 115pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" id=td_post_2783394 class=xl64 width=153>ABC 123 456 DEF</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64 height=20>234 nmn 12 12 VGTH VGTH 234</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64>234 nmn 12 VGTH</TD></TR></TBODY></TABLE>

Formula in B1
=noDups(A1)
copy down

HTH

M.
Click to expand...


I got it to work now but a small problem. Some of the data has dashes and it doesnt do it correct.

e.g

<TABLE style="WIDTH: 218pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=290><COLGROUP><COL style="WIDTH: 218pt; mso-width-source: userset; mso-width-alt: 10605" width=290><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; WIDTH: 218pt; HEIGHT: 12.75pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl64 height=17 width=290>2AD-FTV 2AD-FHV 2AD-FTV 2AD-FHV 2AD-FTV 2AD-FHV

becomes
<TABLE style="WIDTH: 218pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=290><COLGROUP><COL style="WIDTH: 218pt; mso-width-source: userset; mso-width-alt: 10605" width=290><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; WIDTH: 218pt; HEIGHT: 12.75pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl66 height=17 width=290>2AD FTV FHV</TD></TR></TBODY></TABLE>

instead of 2AD-FTV 2AD-FHV

</TD></TR></TBODY></TABLE>
 
Upvote 0
dazwm said:
Yes, some of the data is proper case, so I need the code to be non-case sensitive please. I cant really post the file as it is sensitive information, which is why I used ABC, 123 etc..
Click to expand...
Okay, give this modified version of my original code a try...
Code: 
Sub RemoveDuplicatesFromCells()
  Dim Cell As Range, FirstOne As Long, CellText As String, FirstWord As String, OneWord As Variant, Words() As String
  Const RemoveMe As String = "ABC,123"   'NOTE - no spaces around the commas
  Words = Split(RemoveMe, ",")
  For Each Cell In ActiveCell.EntireColumn.SpecialCells(xlCellTypeConstants)
    CellText = Cell.Value
    For Each OneWord In Words
      If InStr(1, CellText, OneWord, vbTextCompare) Then
        FirstOne = InStr(1, CellText, OneWord, vbTextCompare)
        FirstWord = Mid(CellText, FirstOne, Len(OneWord))
        CellText = Replace(CellText, OneWord, "", , , vbTextCompare)
        CellText = WorksheetFunction.Trim(Left(CellText, FirstOne) & " " & FirstWord & " " & Mid(CellText, FirstOne + 1))
      End If
      Cell.Value = CellText
    Next
  Next
End Sub
 
Upvote 0
Rick Rothstein said:
Okay, give this modified version of my original code a try...
Code: 
Sub RemoveDuplicatesFromCells()
  Dim Cell As Range, FirstOne As Long, CellText As String, FirstWord As String, OneWord As Variant, Words() As String
  Const RemoveMe As String = "ABC,123"   'NOTE - no spaces around the commas
  Words = Split(RemoveMe, ",")
  For Each Cell In ActiveCell.EntireColumn.SpecialCells(xlCellTypeConstants)
    CellText = Cell.Value
    For Each OneWord In Words
      If InStr(1, CellText, OneWord, vbTextCompare) Then
        FirstOne = InStr(1, CellText, OneWord, vbTextCompare)
        FirstWord = Mid(CellText, FirstOne, Len(OneWord))
        CellText = Replace(CellText, OneWord, "", , , vbTextCompare)
        CellText = WorksheetFunction.Trim(Left(CellText, FirstOne) & " " & FirstWord & " " & Mid(CellText, FirstOne + 1))
      End If
      Cell.Value = CellText
    Next
  Next
End Sub
Click to expand...

Again I highlight the column run your code and nothing happens. It isnt just looking for ABC and 123 is it?
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Pivot Table Sorting
Replies
1
Views
877
RoryA
RoryA
K
  • Solved
Formula to highlight cells if one cell contains specific text and another cell has only one of two requirements
Replies
8
Views
930
kmsprague
K
S
  • Question Question
A tricky array sum question into a single cell...
Replies
4
Views
313
etaf
etaf
R
  • Solved
Setting up a test for students to get the right answer
Replies
9
Views
337
RodneyW
R
F
  • Question Question
Macro to add preexisting column value into newly created row
Replies
5
Views
424
alansidman
A

Forum statistics

Threads
1,224,584
Messages
6,179,693
Members
452,938
Latest member
babeneker

Share this page

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
Back
Top