Instead of receiving the first 12 character from the right, what's needed is the same cell without the first 12 characters.
Dim arrData As Variant, LastRow As Long, i As Long, ws As Worksheet
Set ws = ThisWorkbook.Sheets("Long List 15032019") 'change the name of the sheet to the one you are doing the code
With ws
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
arrData = .Range("A2", .Cells(LastRow, "C")).Value
For i = 1 To UBound(arrData)
If arrData(i, 3) Like "Bus*" Then
arrData(i, 1) = "BU CRM"
Else
arrData(i, 1) = "CSI ACE"
End If
If arrData(i, 3) Like "CSI*" Or arrData(i, 3) = vbNullString Then
arrData(i, 2) = vbNullString
Else: arrData(i, 2) = Right(arrData(i, 3), 12)
End If
Next i
.Range("A2", .Cells(LastRow, "C")).Value = arrData
End With
i.e. If C3 = "Example (ID:15654534)" then B3 = "(ID:15654534)" or If C3 = "Example (ID:152)" then B3 = "(ID:152)"
I did attempt using Left or -12. But the outcome was not what I needed.
I hope that this clarifies my question.
Thank you
Sounds like you want a regex. In this case you would have
arrData(i,2) = GetId(arrData(i, 3) , "ID:\d+")
Code:
Option Explicit
Public Sub test()
Dim items(), item As Variant
items = Array("Example (ID:15654534)", "Example (ID:152)")
For Each item In items
Debug.Print GetId(item, "ID:\d+")
Next
End Sub
Public Function GetId(ByVal inputString As String, ByVal sPattern As String) As String
Dim matches As Object, iMatch As Object, arrMatches(), i As Long
i = 1
With CreateObject("vbscript.regexp")
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = sPattern
If .test(inputString) Then
Set matches = .Execute(inputString)
ReDim arrMatches(1 To matches.Count)
For Each iMatch In matches
arrMatches(i) = iMatch.Value
i = i + 1
Next iMatch
Else
GetId = "No match"
Exit Function
End If
End With
GetId = arrMatches(1)
End Function
This can be done without VBA, but only if input is the same structure. Your data now is:
text(idnumber) and you want to obtain only part (idnumber) including both parenthesis.
This formula will work ONLY as long as data structure is the same. If input changes something, it could not work properly (For example, if first parenthesis is missing, it won't work properly).
The formula I've used is this one:
=MID(C1;SEARCH("(";C1;1);SEARCH(")";C1)-SEARCH("(";C1;1)+1)
My data example:
Hope you can adap it to your needs.
Related
I have few values in column I and column H, i have a code which highlights specific words in H column if those words are exactly present in I column.
Drawback is it highlights the works only if they are exactly ditto and are present together, Can any changes be made in the code and make highlight each word even if they are not together
attaching a image of what i want vs what i have, also attaching the existing code.
Dim c1 As Range, c2 As Range, md As Variant, i As Long, w1 As String, os As Long
Set c1 = Range("I2")
Set c2 = Range("H2")
md = Range(c1, Cells(Rows.Count, c1.Column).End(xlUp)).Value
For i = 1 To UBound(md)
If md(i, 1) <> "" Then
w1 = c2.Cells(i, 1).Value
os = InStr(1, w1, md(i, 1), vbTextCompare)
While os > 0
c2.Cells(i, 1).Characters(Start:=os, Length:=Len(md(i, 1))).Font.Color = vbBlue
os = InStr(os + 1, w1, md(i, 1), vbTextCompare)
Wend
End If
Next i
It would be a great help if someone solves my problem.
For pattern matching use a Regular Expression.
Option Explicit
Sub markup()
Dim regex As Object, m As Object, ar
Dim pattern As String, s As String
Dim Lastrow As Long, i As Long, k As Long, n As Long, p As Long
' Create regular expression.
Set regex = CreateObject("VBScript.RegExp")
With regex
.IgnoreCase = True
.Global = True
End With
'update sheet
With ActiveSheet
Lastrow = .Cells(.Rows.Count, "I").End(xlUp).Row
For i = 2 To Lastrow
pattern = Replace(.Cells(i, "I"), ",", "|")
If Len(pattern) > 0 Then
regex.pattern = pattern
s = .Cells(i, "H")
If regex.test(s) Then
' markup matches
Set m = regex.Execute(s)
For k = 0 To m.Count - 1
p = m(k).firstindex + 1
n = Len(m(k))
With .Cells(i, "H").Characters(Start:=p, Length:=n)
.Font.Color = vbBlue
.Font.Bold = True
End With
Next
End If
End If
Next
End With
End Sub
I am new to VBA in Excel. I have a spreadsheet that always has 172 columns. A:FP. It may have 2 to many rows. For every cell in the spreadsheet, I want to remove all leading and trailing spaces along with any leading or trailing "/" or "\". A string can contain a back or forward slash, just not at the beginning or end of the string. My code removes leading and trailing blank spaces. It removes trailing back or forward slashes. However, it does not remove leading slashes. I cannot understand why. Is there a better way of accomplishing my goal? Thank you for your help.
For Each Rng In ActiveSheet.UsedRange
CellVal = Trim(Rng.Value)
LengT = Trim(Len(CellVal))
If CellVal <> "" Then
If Not Rng.HasFormula Then
While Trim(Left(CellVal, 1) = Chr(47)) Or Trim(Left(CellVal, 1) = Chr(92)) Or Trim(Right(CellVal, 1) = Chr(47)) Or Trim(Right(CellVal, 1) = Chr(92))
If Trim(Left(CellVal, 1) = Chr(47)) Or Trim(Left(CellVal, 1) = Chr(92)) Then
CellVal = Trim(Mid(CellVal, 2, LengT))
ElseIf Trim(Right(CellVal, 1) = Chr(47)) Or Trim(Right(CellVal, 1) = Chr(92)) Then
LengT = Len(CellVal)
CellVal = Trim(Left(CellVal, LengT - 1))
Rng.Value = CellVal
LengT = LengT - 1
End If
Wend
End If
End If
Next Rng
First, I'd say try to avoid UsedRange but find a way to get your last used row and column. Then, instead of making a ton of calls to the Worksheet object, I'd run over your values in memory through the use of an array.
Last, you can do many replacements etc. But maybe using a regular expression isn't out of place here. Just for inspirations, I'll put down the following:
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lr As Long, lc As Long, x As Long, y As Long
Dim arr As Variant
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.regexp")
'Set up regular expression first
RegEx.Global = True
RegEx.Pattern = "^[ \/\\]*(.*?)[ \/\\]*$"
With ws
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range(.Cells(1, 1), .Cells(lr, lc)).Value
For x = LBound(arr, 1) To UBound(arr, 1)
For y = LBound(arr, 2) To UBound(arr, 2)
If RegEx.Test(arr(x, y)) Then arr(x, y) = RegEx.Execute(arr(x, y))(0).submatches(0)
Next
Next
.Range(.Cells(1, 1), .Cells(lr, lc)).Value = arr
End With
End Sub
So in the end it's reading back the cleaned data to the worksheet.
Regex Demo
I have searched many posts, forums, tutorials, I tried combine some of them, but nothing really worked for me. Now I write some code, that by logic I learn from other programming languages it should work, but I'm missing few steps.
Let's assume I have string like this
Test User <TUser#my-domain.pl>; Test User2 <TUser2#my-domain.pl>; Test User3 <TUser3#my-domain.pl>; Test User4 <TUser4#my-domain.pl>;
I paste that into cell, let's say A1. My goal is to be left with Test User or TUser for each smaller string.
I can achive my goal by doing so:
Click Text as columns -> Delimited -> Other ;, now each string is in separate column
Copy whole A row and paste it with transpose(rotate), so each string is in separate row
Now easiest way is to use Text as columns, by < delimiter. So all I'm left with is Name Surname in one cell and rest in other
I want to achive that, by clicking on the button of course.
My code so far:
Sub GetName()
Dim WordList As String
Dim ArrayOfWords
Dim i, i2 As Integer
'Define my word list, based on cell
WordList = Cells(1, 1)
'Use SPLIT function to convert the string to an array
ArrayOfWords = Split(WordList, "<")
'Iterate through array, and put each string into new row cell
i = 2
i2 = 1
Do While (ThereIsNoMoreText)'That I cannot figure out
Cells(2, i).Value = ArrayOfWords(i2)
i = i + 1
i2 = i2 + 1
Loop
End Sub
Thanks for you help in advance and I hope I make it clear :)
Fun little alternative:
Sub Test()
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(?:<.*?>)"
arr = Split(.Replace([A1], ""), ";")
End With
With Cells(1, 2).Resize(UBound(arr))
.Value = Application.Transpose(arr)
.Value = Application.Trim(.Value)
End With
End Sub
Obviously, be sure to create an explicit sheet reference for Cells.
You need to split by semicolon first.
Break the following apart to get the strings you need:
userlist = Split(Cells(1, 1).Value, ";")
i = 1
For Each user In userlist
i = i + 1
splituser = Split(user, "<")
Cells(i, 1) = splituser(0)
Cells(i, 2) = Mid(splituser(1), 1, Len(splituser(1)) - 1)
Next
In addition to the methods shown in others answers (in particular the very impressive one by #JvdV) you could also try this.
This method does not use For…Next
Sub Users_Email_Split()
Dim aData As Variant
With ThisWorkbook.Worksheets("TEST")
aData = .Cells(1).Value
aData = Left(aData, -2 + Len(aData))
aData = Replace(aData, " <", """,""")
aData = Replace(aData, ">; ", """;""")
aData = "{""" & aData & """}"
aData = Application.Evaluate(aData)
.Cells(2, 2).Resize(UBound(aData), UBound(aData, 2)).Value = aData
End With
End Sub
EDIT
If the string is expected to exceed the 255 characters limit for the Evaluate Function then you could use this method (up to a max of 2086 characters).
This method a creates an User Defined Name with the array string as a formula, then applies the Name as a FormulaArray, and finally sets the value of the range.
Sub Users_Email_Split_Plus255()
Dim aData As Variant
Dim lR As Long, lC As Long
With ThisWorkbook.Worksheets("TEST")
aData = .Cells(11, 1).Value
aData = Left(aData, -2 + Len(aData))
aData = Replace(aData, " <", """,""")
aData = Replace(aData, ">; ", """;""")
aData = "={""" & aData & """}"
lR = 1 + UBound(Split(aData, ";"))
lC = 1 + UBound(Split(Split(aData, ";")(0), ","))
With .Cells(12, 2).Resize(lR, lC)
.Worksheet.Names.Add Name:="_FmlX", RefersTo:=aData
.FormulaArray = "=_FmlX"
.Value = .Value
End With: End With
End Sub
You have to modify the construct a bit
Dim i As Long
Dim FirstPart As String, SecondPart As String
Dim ArrayOfWords
ArrayOfWords = Split(Cells(1, 1).Value, ";")
For i = LBound(ArrayOfWords) To UBound(ArrayOfWords)
If InStr(1, ArrayOfWords(i), "<") > 0 Then
FirstPart = Left(ArrayOfWords(i), InStr(1, ArrayOfWords(i), "<") - 1)
SecondPart = Mid(ArrayOfWords(i), Len(FirstPart) + 1, Len(ArrayOfWords(i)))
Debug.Print FirstPart & "--" & SecondPart
End If
Next i
Disclaimer- my case is specific, and in my case my code works because I know the pattern.
I was looking for an answer everywhere, and the codes I tried were not quite what I was looking for, this is my solution if you are looking for a set of numbers.
In my case, I was looking for 7 digits, starting with digit 1 in a a column with random strings, some string had the number some others didn't.
The number will appear in these three scenarios "1XXXXXX", "PXXXXXXXX", "PXXXXXXXXX"(this has more digits because there is a slash).
Here are the examples of strings:
9797 P/O1743061 465347 Hermann Schatte Earl Lowe
9797 Po 1743071 404440 Claude Gaudette Jose Luis Lopez
9817 1822037 463889 Jean Caron Mickelly Blaise
My Code
Sub getnum()
'i don't use explicit so i didn't declare everything
Dim stlen As String
Dim i As Integer
Dim arra() As String
Dim arran() As String
Orig.AutoFilterMode = False
Call BeginMacro
LastRow = Orig.Cells(Rows.Count, 1).End(xlUp).Row
Orig.Range("J2:J" & LastRow).Clear
'loop though column
For n = 2 To LastRow
celref = Orig.Cells(n, 4).Value
'split string on white spaces
arra() = Split(celref, " ")
'turn string to multiple strings
For counter = LBound(arra) To UBound(arra)
strin = arra(counter)
'remove white spaces from string
storage = Trim(strin)
lenof = Len(storage)
'if string has 9 characthers, check for conditions
If lenof = 9 Then
'position of first and last charachter
somstr = Mid(storage, 1, 1)
somot = Mid(storage, 9, 1)
If somstr = "P" Or somstr = "p" And IsNumeric(somot) = True Then
'removes Po or PO and keeps only 7 digits
storage = Right(storage, 7)
'stores in column J
Orig.Cells(n, 10).Value = storage
End If
ElseIf lenof = 10 Then
somstr = Mid(storage, 1, 1)
somot = Mid(storage, 10, 1)
'other conditions
If somstr = "P" Or somstr = "p" And IsNumeric(somot) = True Then
'removes Po or PO and keeps only 7 digits
storage = Right(storage, 7)
'stores in column J
Orig.Cells(n, 10).Value = storage
End If
End If
'eliminate comma within
arran() = Split(storage, ",")
If Orig.Cells(n, 10).Value <> storage Then
For counter2 = LBound(arran) To UBound(arran)
strin2 = arran(counter2)
storage2 = Trim(strin2)
'final condition if is 7 digits and starts with 1
If IsNumeric(storage2) = True And Len(storage2) = 7 Then
car = Mid(storage2, 1, 1)
If car = 1 Then
'stores in columns J at specific position
Orig.Cells(n, 10).Value = storage2
End If
Else
If isnumeric(orig.cells(n,10).value) =true and _
len(orig.cells(n,10).value = 7 then
orig.cells(n,10).value = orig.cells(n,10).value
else
Orig.Cells(n, 10).Value = "no po# in D"
End If
Next counter2
End If
Next counter
Next n
Call EndMacro
End Sub
you may try this
Option Explicit
Sub getnum()
Dim position As Variant
Dim cell As Range
With Worksheets("Orig") ' change it to your actual sheet name
With Intersect(.UsedRange, Columns("J"))
.Replace what:="P/O", replacement:="P/O ", lookat:=xlPart
For Each cell In .Cells
position = InStr(cell.Text, " 1")
If position > 0 Then cell.Value = Mid(cell.Value, position + 1, 7)
Next
End With
End With
End Sub
This code paste two formulas one in column G and one in column J). The first formula checks for a "P" in the first character of the cell in column 2 and if there is a "P" it extracts the last 7 characters in the string and puts them in column G. The second formula checks if there is not a "P" and if not extracts the last 7 characters in the string and puts them in column J.
Sub Extract()
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet3")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("G2:G" & lRow).Formula = "=IF(LEFT(B2)=""P"",(RIGHT(B2,7)),"""")"
ws.Range("J2:J" & lRow).Formula = "=IF(LEFT(B2)<>""P"",(RIGHT(B2, 7)),"""")"
End Sub
You may use the RegEx to extract the number in desired format.
Please give this a try...
Function Get10DigitNumber(ByVal Str As String) As String
Dim RE As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
.Global = False
.Pattern = "1\d{6}"
End With
If RE.test(Str) Then
Get10DigitNumber = RE.Execute(Str)(0)
End If
End Function
Then if you want to use this function on the worksheet itself, assuming your string is in A2, try this...
=Get10DigitNumber(A2)
OR
You may use this function in another sub routine/macro like this...
Debug.Print Get10DigitNumber(<pass your string variable here>)
Edited Function:
Function Get10DigitNumber(ByVal Str As String) As String
Dim RE As Object, Matches As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
.Global = False
.Pattern = "[Pp]?\/?[Oo]?(1\d{6})\b"
End With
If RE.test(Str) Then
Set Matches = RE.Execute(Str)
Get10DigitNumber = Matches(0).SubMatches(0)
End If
End Function
And use if as already described above.
After understanding what you were doing, I think this will work. Any feedback would be appreciated.
Dim cell As Range, LRow As Long
LRow = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
For Each cell In Range("D2:D" & LRow)
If cell.Value Like "*Po *" Then
cell.Offset(0, 6).Value = Split(cell.Value, " ")(2)
Else: cell.Offset(0, 6).Value = Split(cell.Value, " ")(1)
End If
Next cell
For Each cell In Range("J2:J" & LRow)
If Len(cell.Value) > 7 Then
cell.Value = Right(cell.Value, 7)
End If
Next
What I am doing is search some strings one by one in the entire range - like search for "blah1", if found then exit, else search "blah2" in the entire range in the same manner. "blah's" are searched in one column.
Right now i am just running a For loop code as shown below which so far works ok in my tests...but was wondering if MATCH, FIND or other methods may be faster...any opinion?
Sub test()
Dim LR As Long
LR = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
If Cells(1, "B") = "" Then
For i = 1 To LR
If Cells(i, "A") = "blah1" Then
Cells(1, "B") = Cells(i, "A").Row
Cells(1, "C") = Cells(i, "A")
Exit For
End If
Next i
End If
If Cells(1, "B") = "" Then
For i = 1 To LR
If Cells(i, "A") = "blah2" Then
Cells(1, "B") = Cells(i, "A").Row
Cells(1, "C") = Cells(i, "A")
Exit For
End If
Next i
End If
End Sub
Try this one. Since your code is repeated (for "blah1" and "blah2") I used additional function:
Sub test()
If Sheet1.Cells(1, "B") = "" Then
If findString("blah1") Then Exit Sub
If findString("blah2") Then Exit Sub
End If
End Sub
'Function findString returns TRUE if something found and FALSE otherwise
Function findString(searchString As String) As Boolean
Dim rng As Range, res
With Sheet1
Set rng = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
res = Application.Match(searchString, rng, 0)
'Application.Match returns error if nothing found
findString = Not IsError(res)
If findString Then
.Cells(1, "B").Value = rng.Cells(res, 1).Row
.Cells(1, "C").Value = searchString
End If
End With
End Function
I'm reasonably new to Excel Vba, but my limited understanding is that reading from cells is relatively slow. If I were doing this I would read all the values into an array, and carry out the same for loop as you have used, but on the array, rather than cell values.
To confirm, you could use VBAs Timer function to check speed.
Let me know if you'd like more detailed explanations of how to do this.
Here's how you can turn a range into an array (and vice versa). Step through this code with the Locals window turned on and watch what happens. You are particularly interested in the astrArray variable.
Sub ChangeArray()
'
Dim astrArray As Variant
'
' Dim astrArray
' that is, with no type specified
' is exactly equivalent
'
Dim lngIndex As Long
Dim strMessage As String
'
Range("A1").Value = "This"
Range("A2").Value = "is"
Range("A3").Value = "only"
Range("A4").Value = "a"
Range("A5").Value = "test"
astrArray = Range("A1:A5")
For lngIndex = 1 To 5
strMessage = strMessage & astrArray(lngIndex, 1) & " "
Select Case lngIndex
Case 1
astrArray(lngIndex, 1) = "No,"
Case 2
astrArray(lngIndex, 1) = "it's"
Case 3
astrArray(lngIndex, 1) = "actually"
Case 4
astrArray(lngIndex, 1) = "real"
Case 5
astrArray(lngIndex, 1) = "life"
End Select
Next lngIndex
MsgBox strMessage
Range("A1:A5") = astrArray
End Sub
A key requirement: to do this, the variable must be DIMmed Variant!
Another thing to pay attention to: the variable is two-dimensional, even though the range selected is one-dimensional.