I have duplicate email ids in an excel cell. (Each cell has around 5 to 6 emails which are repeated as below). Is there a macro to remove unique ones from the cell ? I have given an example below for reference, appreciate your assistance.
Cell 1
abc#cc.com
cde#bb.com
abc#cc.com
lmn#nn.com
cde#bb.com
Cell 2
jjj#cc.com
kk#dd.com
jjj#cc.com
Thanks
Auro
I used your data in a blank worksheet in Column A, and the output gets put in Column B.
You can change the loops and cell references to suit your needs.
I've also assumed you want the email addresses that were contained in a cell to remain grouped (once the duplicates have been removed) in the output.
This code also assumes the email addresses are separated by a 'carriage return'
Sub removeDuplicate()
'references: http://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array
Dim wks As Worksheet
Dim rng As Range
Dim wordCount As Integer
Dim d As Object
Dim i As Integer
Dim j As Integer
Dim v As Variant
Dim outText As String
Set wks = Worksheets("Sheet1") '<- change sheet to suit needs
For j = 1 To 2 '<- change loop to suit needs
Set rng = wks.Range(Cells(j, 1), Cells(j, 1)) '<- change cell reference as required
Set d = CreateObject("Scripting.Dictionary")
'use carriage return (chr(10)) as the 'find' text
'Count Words/email addresses
wordCount = Len(rng) - Len(Replace(rng, Chr(10), "")) + 1
'split words by carriage return
arrWords = Split(rng, Chr(10))
For i = 0 To wordCount - 1
d(arrWords(i)) = 1
Next i
'create output text by re-grouping the split text.
outText = ""
For Each v In d.keys
If outText = "" Then
outText = v
Else
outText = outText & Chr(10) + v
End If
Next v
'output to adjacent cell
rng.Offset(0, 1).Value = outText
Set d = Nothing
Next j
Set wks = Nothing
End Sub
Related
I have been searching for a while now a code to help me to extract superscript characters (number 1 and 2) that are either in the middle or at the end of a string in column A. I need to cut them from the string and paste them into the same row, but on column C as a normal number.
I did not find any suitable solutions I could evev try. So I do not have any code because I do not know where to start. My data will have always less than 500 lines and has the same structure, but lines with superscript change.
Does anyone know to solve this problem please? Thanks a lot.
I would really appreciate the help.
Desired output: for every row where there is a superscript, cut it from string in Column A and paste it in column C as a normal number..
Sub extractSuperscript()
Dim rng As Range
Dim cell As Range
Dim i As Long
Dim j As Long
Dim result As String
' Define the range to process
Set rng = Range("A1:A10")
' Loop through each cell in the range
For i = 1 To rng.Cells.Count
Set cell = rng.Cells(i)
result = ""
' Loop through each character in the cell
For j = 1 To Len(cell.Value)
' Check if the character is a superscript 1 or 2
If Mid(cell.Value, j, 1) = "¹" Or Mid(cell.Value, j, 1) = "²" Then
' If the character is a superscript 1, add a 1 to the result string
If Mid(cell.Value, j, 1) = "¹" Then
result = result & "1"
' If the character is a superscript 2, add a 2 to the result string
ElseIf Mid(cell.Value, j, 1) = "²" Then
result = result & "2"
End If
End If
Next j
' Paste the result string into column C and remove the superscript from column A
cell.Offset(0, 2).Value = result
cell.Value = Replace(cell.Value, "¹", "")
cell.Value = Replace(cell.Value, "²", "")
Next i
End Sub
Let me know if this works
Let me know if the following works:
Option Explicit
Sub Superscript()
Application.ScreenUpdating = True
Dim wb As Workbook
Dim ws As Worksheet
Dim rngSuperscript As Range, c As Range
Dim iCount As Integer
Dim MyString As String
Set wb = ThisWorkbook
'Set it to sheet name where your data is
Set ws = wb.Sheets("Test")
'Change it to reflect your data
Set rngSuperscript = ws.Range("A2:A11")
For Each c In rngSuperscript
'temp text variable
MyString = c.Value
'loop through the string value
For iCount = 1 To Len(MyString)
'check if it is numeric
If IsNumeric(Mid(MyString, iCount, 1)) Then
'combine with the C column value (if any)
c.Offset(0, 2).Value = CLng(c.Offset(0, 2).Value & Mid(MyString, iCount, 1))
End If
Next
Next c
Application.ScreenUpdating = False
End Sub
Need some help with an Excel macro-- I'm currently struggling to write a macro that combines all three processes. I have two sheets: Sheet 1 contains a column with multiple IDs in each cell delimited by commas (can go up to like 30 IDs in one cell), Sheet 2 contains data for each of the IDs.
Here's the sequence that I'm trying to achieve:
De-concatenate IDs in Sheet 1 into separate cells
Match each of the de-concatenated IDs to its row in Sheet 2, copy over and add values from column 6 and 7 to Sheet 1's respective cell.
Apply a hyperlink to the final cell.
For example, here's what a row in Sheet 1 & 2 currently look like:
Sheet 1
ID
123456, 789123
Sheet 2
ID
Status
Class
123456
In Progress
A
789123
Done
B
And here's what I'd like the output to look for Sheet 1 when the macro runs:
ID
123456, 789123
123456, In Progress, A
789123, Done, B
My code is super off, but here's what I have:
Set wb = ThisWorkbook
Dim sel As Range
Set sel = Selection
Dim arr() As String
Dim cell As Range
Dim i As Long
Set wsCheck = wb.Sheets("2")
'Column N (IDs)
wb.Sheets("1").Columns("N:N").Select
For Each cell In sel
arr = Split(cell, ",")
For i = 0 To UBound(arr)
m = Application.Match("*" & arr(i) & "*", wsCheck.Columns(1), 0)
If Not IsError(m) Then
cell.Offset(0, i + 1).Value = wsCheck.Cells(m, 6).Value & wsCheck.Cells(m, 7).Value
cell.Parent.Hyperlinks.Add Anchor:=cell.Offset(0, i + 1), Address:="URL" & arr(i), TextToDisplay:=arr(i)
End If
Next i
Next cell
Try this:
Sub test()
Dim wb As Workbook, arr, ws As Worksheet, wsCheck As Worksheet
Dim cell As Range
Dim i As Long, v, m
Set wb = ThisWorkbook
Set ws = wb.Sheets("1")
Set wsCheck = wb.Sheets("2")
If Not TypeOf Selection Is Range Then Exit Sub 'make sure a range is selected
If Selection.Worksheet.Name <> ws.Name Then Exit Sub '...on the correct sheet
For Each cell In Selection.EntireRow.Columns("N").Cells
arr = Split(cell.Value, ",")
For i = 0 To UBound(arr)
v = CLng(Trim(arr(i))) 'remove spaces and convert to number
m = Application.Match(v, wsCheck.Columns(1), 0)
If Not IsError(m) Then
With cell.Offset(0, i + 1)
.Value = Join(Array(v, wsCheck.Cells(m, 6).Value, _
wsCheck.Cells(m, 7).Value), ",")
.Parent.Hyperlinks.Add Anchor:=.Cells(1), _
Address:="", _
SubAddress:=wsCheck.Cells(m, 1).Address(0, 0, xlA1, True), _
TextToDisplay:=.Value
End With
End If
Next i
Next cell
End Sub
I am not that much familiar in VBA code. I am looking to implement two scenarios using VBA code in excel.
Scenario 1: If the value in the "C" column contains specific text, then replace the corresponding values in the "A" column as below
If the value in C contains "abc" then A= "abc".
If the value in C contains "gec" then A= "GEC".
It should loop from the second row to last non-empty row
A
B
C
Two
abc-def
Thr
gec-vdg
Thr
abc-ghi
Expected Result:
A
B
C
abc
Two
abc-def
gec
Thr
gec-vdg
abc
Thr
abc-ghi
Scenario 2: If the value in the "B" column is "A", then replace all the "A" value in the B column as "Active". If the value in the "B" column is I", then replace all the I value in the B column as inactive.
It should loop from the second row to last non-empty row
A
B
C
abc
A
abc-def
gec
I
gec-vdg
abc
A
abc-ghi
Expected Result:
A
B
C
abc
Active
abc-def
gec
Inactive
gec-vdg
abc
Active
abc-ghi
I know that it is possible by using excel formulas. Wondering, how it can be implemented using vba code in excel.
Usually people on here won't just write code for you, this is more for helping you with your code when your stuck. However I've written one for you based on the information you have provided. I've assumed your cells in column C would always have the hyphen and you always want what's left of the hyphen. If there is no hyphen or the relevant cell in column C is empty then nothing will be put into the relevant cell in column A.
I've put in to turn off ScreenUpdating for the code as I don't know how many rows you have. If it's a lot and you have a lot going on, then we can also turn off Calculation and Events to speed it up more, or run it as an array if it's really slow but I suspect that it won't be an issue.
Paste this into your relevant sheet module and change the sheet name as well as the column that's finding the last row if C isn't the right one:
Sub UpdateCells()
Application.ScreenUpdating = False
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Sheet1") 'Change Sheet1 to your sheet name
lRow = ws.Range("C" & Rows.Count).End(xlUp).Row 'Finds your last row using Column C
With ws
For i = 2 To lRow 'Loop from row 2 to last row
If .Range("B" & i) = "A" Then
.Range("B" & i) = "Active"
ElseIf .Range("B" & i) = "I" Then
.Range("B" & i) = "Inactive"
End If
If .Range("C" & i) <> "" Then
If InStr(.Range("C" & i), "-") > 0 Then 'If current row Column C contains hyphen
.Range("A" & i) = Left(.Range("C" & i), InStr(.Range("C" & i), "-") - 1)
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Replace Values
Option Explicit
Sub replaceCustom()
' Define constants.
Const wsName As String = "Sheet1"
Const ColumnsAddress As String = "A:C"
Const FirstRow As Long = 2
Dim Contains As Variant: Contains = VBA.Array(3, 1) ' 0-read, 1-write
Const findContainsList As String = "abc,gec" ' read
Const replContainsList As String = "abc,gec" ' write
Dim Equals As Variant: Equals = VBA.Array(2, 2) ' 0-read, 1-write
Const findEqualsList As String = "A,I" ' read
Const replEqualsList As String = "Active,Inactive" ' write
Dim CompareMethod As VbCompareMethod: CompareMethod = vbTextCompare
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define range.
Dim rng As Range
With wb.Worksheets(wsName).Columns(ColumnsAddress)
Set rng = .Resize(.Worksheet.Rows.Count - FirstRow + 1) _
.Offset(FirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - FirstRow + 1).Offset(FirstRow - 1)
End With
' Write values from range to array.
Dim Data As Variant: Data = rng.Value
' Write lists to arrays.
Dim findCo() As String: findCo = Split(findContainsList, ",")
Dim replCo() As String: replCo = Split(replContainsList, ",")
Dim findEq() As String: findEq = Split(findEqualsList, ",")
Dim replEq() As String: replEq = Split(replEqualsList, ",")
' Modify values in array.
Dim i As Long
Dim n As Long
For i = 1 To UBound(Data, 1)
For n = 0 To UBound(Contains)
If InStr(1, Data(i, Contains(0)), findCo(n), CompareMethod) > 0 Then
Data(i, Contains(1)) = replCo(n)
Exit For
End If
Next n
For n = 0 To UBound(Equals)
If StrComp(Data(i, Equals(0)), findEq(n), CompareMethod) = 0 Then
Data(i, Equals(1)) = replEq(n)
Exit For
End If
Next n
Next i
' Write values from array to range.
rng.Value = Data
End Sub
I've searched the forums and found some great Excel VBA code to find and highlight duplicate cell values in a given dataset range.
However, the cell values in my dataset are paragraphs. This means some cell values in the dataset will be greater than 255 characters. When I run the code below, duplicate cells are highlighted until the code encounters a cell value greater than 255 charactions. This appears to cause the "countif" function to throw the error:
Run-time error '1004':
Unable to get CountIf property of the WorksheetFunction class
Any ideas on how to pass a Cell.Value greater than 255 characters to CountIf, or another idea to compare cell values greater than 255 characters to highlight duplicates?
Sub findDuplicates()
Const headRow As Integer = 7 'row that contains the table heading row for the dataset
Dim lastRow As Integer
Dim rng As Range
With ThisWorkbook.Worksheets(1)
lastRow = .Range("F" & Rows.Count).End(xlUp).Row 'finds last row in dataset
Set rng = .Range(Cells(headRow + 1, 6), Cells(lastRow, 6)) 'sets the range of the dataset between the headRow and lastRow
End With
For Each Cell In rng
If Application.WorksheetFunction.CountIf(rng, Cell.Value) > 1 Then 'tests if there is a duplicate
Cell.Interior.ColorIndex = 6 'highlight yellow
End If
Next Cell
End Sub
To compare cell values with lengths > 255, you can loop through the range doing a cell by cell comparison.
Please read the comments in the code below for further details, and post back with any questions.
Option Explicit 'require declaration of ALL variables
'go to Tools/Options/Editor and set "Require Variable Declaration"
Option Compare Text 'for case insensitive
Sub findDuplicates()
'Use Long instead of integer
' Plenty of articles as to why
Const headRow As Long = 7 'row that contains the table heading row for the dataset
Dim lastRow As Long
Dim rng As Range
Dim Counter As Long
Dim V As Variant, I As Long, J As Long
Dim COLL As Collection
With ThisWorkbook.Worksheets(1)
lastRow = .Range("F" & Rows.Count).End(xlUp).Row 'finds last row in dataset
Set rng = .Range(Cells(headRow + 1, 6), Cells(lastRow, 6)) 'sets the range of the dataset between the headRow and lastRow
End With
'Read range into vba array for faster processing
V = rng
'loop through the array to do the count
Set COLL = New Collection 'collect the duplicate cell addresses
For I = 1 To UBound(V, 1)
Counter = 0
For J = 2 To UBound(V, 1)
If V(J, 1) = V(I, 1) Then 'duplicate
Counter = Counter + 1
If Counter > 1 Then
On Error Resume Next 'avoid duplicate addresses in the collection
COLL.Add Item:=rng(I).Address, Key:=rng(I).Address
On Error GoTo 0
End If
End If
Next J
Next I
'highlight the relevant cells
rng.Interior.ColorIndex = xlNone
For Each V In COLL
Range(V).Interior.ColorIndex = 6
Next V
End Sub
I propose to convert long text into some numeric value. See my function:
Function UnicodeVal(str As String) As Double
Dim l As Long
Dim dblV As Double
dblV = 1
For l = 1 To Len(str)
If l Mod 2 Then
dblV = dblV * AscW(Mid(str, l, 1))
Else
dblV = dblV / AscW(Mid(str, l, 1))
End If
UnicodeVal = dblV
Next l
The function multiply and divides Unicode values of all character in the string and returns the score. Because it is multiplying for even numbers and dividing for odd, it is immuned from typos like "hoem" instead of "home". It is unlikely that the score will be the same in case of long strings, I think.
You can use this function in place of direct comparisons.
I have an excel file I want to parse the beginning of each cell in column D and copy and paste the numbers in cell(same row,column B) How do I parse the cells with numbers 0 through 9 and "." and copy just that value x.x.x.x to column B? There is no standard format of how many numbers and periods at the start of the cell in column D. It could be 1.3.4 or 1.3.4. or 1.3 ect...
=====================================================================
'DIMENSIONING VARS AND PATHS
Dim Level As Range
Dim i, j, q(1 To 50) As Long
Dim numofchar As Long
Dim filepath As String
Dim filename As String
Dim PN As String
Dim HEADERrowcallout As Long
Dim LASTREQrowcallout As Long
Dim REQTEXTcolumncallout As String
Dim x As Long
Dim s As String
Dim count As Long
Dim Reqtext As Variant
Dim SectionText As Variant
'
'scanf(Input the correct row and column numbers). Used for determining start and endpoints of filtering files
HEADERrowcallout = InputBox("What row number are your headers in?")
LASTREQrowcallout = InputBox("What row number are your headers in?")
REQTEXTcolumncallout = InputBox("What is the column letter where ReqText is located? (A=1,B=2,D=4,ect...)")
'REQTYPEcolumncallout = InputBox("What is the column number from the left where the outline level is located? (A=1, B=2, ect...)")
'SECTIONcolumncallout = InputBox("What is the column number from the left where the outline level is located? (A=1, B=2, ect...)")
'
'stop screen updating
Application.ScreenUpdating = False
'
'show gridlines
ActiveWindow.DisplayGridlines = True
'
'Requirement Text to Section Maker --- Part (1)
'Part 1 filter string for the section number. (Numbers 1-10 & . until letters or space)
'Generate a string using the numbers and letters, ex [1.1.3.], cut & copy data to section column same row
For i = HEADERrowcallout + 1 To LASTREQrowcallout
'Get length of active cell. This is max that copied cell will be
LengthCell = Len(Cells(HEADERrowcallout + 1, REQTEXTcolumncallout))
SectionText = (LengthActiveCell)
Reqtext = (LengthActiveCell)
'while count != length, scan each array position from 0 until array position value != 1-10 or .
While x < LengthActiveCell
Select Case Cells()
Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", "."
Dim count As Long
x = x + 1
'If no more letters or .s, move to next cell
x = LengthCell
'if SectionText() = SectionText(0)
'Keep going down ReqText column until specified end
HEADERrowcallout = HEADERrowcallout + 1
End Sub
===========================
Picture of Excel Sheet
Edit: Now with comments explaining what the code does
Obviously you don't need the comments in your live version.
Paste the code below into a new Module, and then use it as a WorksheetFunction
(I took a guess as to what the function should be called). In any cell, enter =ExtractOutline(<cell address>), where <cell address> is the cell from which you wish to extract the x.x.x. bit.
Function ExtractOutline(strInput As String)
'Function iterates through the input string until we get to a
'character which isn't one in "0123456789." Each character which is
'one of these is added to the output as we go along
Dim strOut As String 'The output we're building
Dim intPos As Integer 'The position we've reached in the input
Dim str1Char As String 'The character found at the current position
intPos = 1 'We'll start at the first character
str1Char = Mid(strInput, intPos, 1) 'Extract the intPos-th character, in this case, the 1st.
While intPos <= Len(strInput) And WorksheetFunction.Find(str1Char, "0123456789." & str1Char) < 12
'While
'intPos <= Len(strInput)
'This makes sure we haven't iterated beyond the end of the input
'AND
'WorksheetFunction.Find(str1Char, "0123456789." & str1Char) < 12
'Looks for the current character in "0123456789."
'If it wasn't found we'd get an error (as output to the function)
'To prevent that add current character to end of "0123456789."
'Since "Find" returns the position, within the string,
'and "01234567890." as 11 characters, we only match the right bit if it
'is found before the 12th character
'Add the character to the output
strOut = strOut & Mid(strInput, intPos, 1)
'Increment ready for next time round the loop
intPos = intPos + 1
'Get the next character to be checked
str1Char = Mid(strInput, intPos, 1)
Wend
ExtractOutline = strOut
End Function
Or you can incorporate the following approach into your code...
Sub Alex()
Dim lr As Long
Dim rng As Range, cell As Range
Dim RE As Object
Dim Match As Object
lr = Cells(Rows.Count, 4).End(xlUp).Row
Set rng = Range("D2:D" & lr)
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "([0-9]\.){1,}"
For Each cell In rng
If RE.test(cell.Value) = True Then
Set Match = RE.Execute(cell.Value)
cell.Offset(0, -2).Value = Left(Match(0), Len(Match(0)) - 1)
End If
Next cell
End Sub
Something like this
You can see RegExp sample here
code
Sub EddieBetts()
Dim rng1 As Range
Dim lngCnt As Long
Dim objRegex As Object
Dim X
Set rng1 = Range([d2], Cells(Rows.Count, "D").End(xlUp))
X = rng1.Value2
Set objRegex = CreateObject("VBScript.RegExp")
objRegex.Pattern = "([0-9\.])+"
For lngCnt = 1 To UBound(X, 1)
If objRegex.test(X(lngCnt, 1)) Then X(lngCnt, 1) = objRegex.Execute(X(lngCnt, 1))(0)
Next
rng1.Offset(0, -2).Value2 = X
End Sub