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
Related
I'm trying to keep the characteristics of the two texts the same. All I want to do is take the text from column A, row 1 and make sure it's repeated in column B, row 1. If it is, I don't have to do anything. If it isn't, then all I would need to do is take the text from first first box, strike it through, make it red, and add it to the text in box 2.
How would I be able to do that? I tried assigning the text as a string to a variable, but when I try to combine it, the all the colors turn to black. Is there any simple approach to this?
Inputs
Desired Output
I'm fairly new to VBA and any help would be greatly appreciated!
As for my code, this is what I have so far, but I think I'll have to completely rewrite it.
x = Cells(i, 1) & "" & " "
w = Cells(i, 2)
If InStr(LCase(Cells(i, 2)), LCase(x)) = 0 Then
full = x & "" & w
Cells(i, 2) = full
End If
For lcounter = 1 To Len(Cells(i, 1))
If Cells(i, 1).Characters(lcounter, 1).Text = Cells(i, 2).Characters(lcounter, 1).Text And Cells(i, 2).Characters(lcounter, 1).Font.ColorIndex = 3 Then
Cells(i, 2).Characters(lcounter, 1).Font.Strikethrough = True
Cells(i, 2).Characters(lcounter, 1).Font.ColorIndex = 3
End If
Next lcounter
This code only works if all of the text in cell 2 is red before merging. For some reason, if that's the case, the combined text is also red.
But otherwise, for the example in the picture, this code doesn't work.
Format Characters
Sub FormatCharacters()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.Range("A1:B1")
Dim Cell1 As Range: Set Cell1 = rg.Cells(1)
Dim Cell2 As Range: Set Cell2 = rg.Cells(2)
If Cell1.Value <> Cell2.Value Then
' Write the formats of the 2nd cell to an array.
Dim Len1 As Long: Len1 = Len(Cell1)
Dim Len2 As Long: Len2 = Len(Cell2)
Dim LB As Long: LB = Len1 + 2
Dim UB As Long: UB = LB + Len2 - 1
Dim arr2() As Variant: ReDim arr2(LB To UB, 1 To 2)
Dim j As Long: j = LB
Dim i As Long
For i = 1 To Len2
With Cell2.Characters(i, 1).Font
arr2(j, 1) = .Color
arr2(j, 2) = .Strikethrough
j = j + 1
End With
Next i
' Concatenate the strings.
Cell2.Value = Cell1.Value & " " & Cell2.Value
' Format the 1st cell's string.
With Cell2.Characters(1, Len1).Font
.Color = vbRed
.Strikethrough = True
End With
' Format the 2nd cell's string.
For j = LB To UB
With Cell2.Characters(j, 1).Font
.Color = arr2(j, 1)
.Strikethrough = arr2(j, 2)
End With
Next j
End If
End Sub
The format of the text I'm dealing with looks like this:
|John| bought an |apple|.
The goal is to find all the text between "|"(like "John" and "apple"), change its color then delete both "|".
My current code is supposed to find the first and second instances of "|", go through each character between the two positions then change its font color, deleting both "|" and loop to do the whole thing again until no "|" can be found.
My problem is it often delete and color the wrong characters. I suspect it has something to do with character positions, but I don't know where.
Relevant code looks like this:
Dim Cell As Range
Dim iChr As Integer, N As Integer, Content As Integer
Dim openPos As Long, Dim clsPos As Long
Dim textBetween As String
For Each Cell In ws.UsedRange' relevant code is going to loop through each cell of each sheet
openPos = 0
N = 1
iChr = InStr(1, Cell.Value, "|")
Do Until iChr = 0 'Loop until no "|"
openPos = InStr(openPos + N, Cell, "|", vbTextCompare) 'first "|"
clsPos = InStr(openPos + 1 + N, Cell, "|", vbTextCompare) 'second "|"
For Content = openPos To clsPos
Cell.Characters(Content, 1).Font.Color = RGB(0, 255, 0)
Next Content
N = N + 1
Cell.Characters(clsPos, 1).Delete 'delete first and second"|"
Cell.Characters(openPos, 1).Delete
iChr = InStr(1, Cell.Value, "^") 'check if there is any "|" left
Loop
Next Cell
Please try this code.
Sub FindColorAndRemove()
' 016
Const Marker As String = "|" ' change to suit
Dim Ws As Worksheet
Dim Fnd As Range, FirstFound As String
Dim Sp() As String
Dim n As Integer
Dim i As Integer
For Each Ws In ActiveWorkbook.Worksheets
' enumerate exclusions here
If Ws.CodeName <> Sheet1.CodeName Then
Set Fnd = Ws.Cells.Find(What:=Marker & "*" & Marker, _
After:=Ws.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchDirection:=xlNext)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Address
Do
With Fnd
Sp = Split(.Value, Marker)
n = 0
.Value = Join(Sp, "")
For i = 0 To UBound(Sp) - 1
If i Mod 2 Then
With .Characters(n + 1, Len(Sp(i)))
.Font.Color = vbRed
.Font.Bold = True
End With
End If
n = n + Len(Sp(i))
Next i
End With
Set Fnd = Ws.Cells.FindNext
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Address <> FirstFound
End If
End If
Next Ws
End Sub
Please pay attention to this line of code, If Ws.CodeName <> Sheet1.CodeName Then. I added it because I didn't want all sheets to be included. You can use the worksheets' tab name or code name. I recommend the CodeName because the user is less likely to change it. If you don't need the feature you can use some irrelevant criterium or delete the entire IF statement, including its End If.
Here is another approach using Collection
Sub Find_Location()
Dim iChr, StartChar, CharLen, i, j, k, m, n As Integer
Dim Ws As Worksheet
Set Ws = ActiveSheet
Dim Occurrence As Collection
For Each Cell In Ws.UsedRange
Set Occurrence = New Collection
i = Len(Cell.Text)
If i = 0 Then GoTo EndOfForLoop
j = 1
k = 0
Do Until j > i
iChr = InStr(j, Cell.Value, "|")
If iChr = 1 Then
k = k + 1
Occurrence.Add iChr
ElseIf iChr > 1 Then
k = k + 1
If Occurrence.Count = 0 Then
Occurrence.Add iChr
ElseIf Occurrence.Count > 0 Then
If (k / 2) = Int(k / 2) Then
Occurrence.Add (iChr - k)
ElseIf (k / 2) <> Int(k / 2) Then
Occurrence.Add (iChr - Occurrence.Count)
End If
End If
ElseIf iChr = 0 Then
If k = 0 Then
GoTo EndOfForLoop
Else
GoTo ModifyContent
End If
End If
j = 1 + iChr
Loop
ModifyContent:
With Cell
.Replace "|", ""
End With
m = 1
n = 2
Do Until n > k
StartChar = Occurrence.Item(m)
CharLen = (Occurrence.Item(n) - Occurrence.Item(m) + 1)
With Cell.Characters(StartChar, CharLen)
.Font.Color = RGB(0, 255, 0)
.Font.Bold = True
End With
m = m + 2
n = n + 2
Loop
EndOfForLoop:
Next
End Sub
SO I have a list of words ( they are 250ish medications in my Settings sheet ) , and I want to use vba to find those specific words in Column D of another sheet and color them magenta. Column D has 105 cells that are full of text.
text I want to search:
list of meds:
what I want it to look like:
below is what iv gathered from other resources but I just cant get it to work! please let me know if you have any suggestions!
also it kinda has to work with mac and windows excel
Sub ColorWords3()
Dim Position As Long, Cell As Range, W As Variant, Words As Variant, Txt As String, druglastcol As Variant, drugs As Variant
druglastcol = Sheets("Settings").Range("A" & Rows.Count).End(xlUp).Row
'Words = Array("TEXT", "WORD", "THEN")
Words = Application.Transpose(Sheets("Settings").Range("A4:A" & druglastcol).Text)
For Each Cell In Columns("D").SpecialCells(xlConstants)
Txt = " " & UCase(Cell.Value) & " "
For Each W In Words
Position = InStr(Txt, W)
Do While Position > 0
If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & W & "[!A-Z0-9]" Then
With Cell.Characters(Position - 1, Len(W)).Font
.Bold = True
.Color = vbRed
End With
End If
Position = InStr(Position + 1, Txt, W)
Loop
Next
Next
End Sub
Like is case-sensitive, so you need to upper-case your drug names to match your upper-cased blocks of text.
If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & UCase(W) & "[!A-Z0-9]" Then
Using Like gets a bit clunky so here's a RegExp-based approach:
EDIT - added a working Like/InStr version...
Sub ColorWords()
Dim Cell As Range, W, Words, matches As Collection, m
With Sheets("Settings")
Words = Application.Transpose(.Range(.Range("A4"), _
.Cells(.Rows.Count, 1).End(xlUp)))
End With
For Each Cell In ActiveSheet.Columns("D").SpecialCells(xlConstants)
For Each W In Words
'Set matches = AllMatchesRegEx(Cell.Text, W) 'windows only
Set matches = AllMatchesInStr(Cell.Text, W) 'windows+mac
For Each m In matches
Debug.Print Cell.Address, W, m
With Cell.Characters(m, Len(W)).Font
.Bold = True
.Color = vbMagenta
End With
Next m
Next
Next
End Sub
Function AllMatchesInStr(ByVal textToSearch As String, searchTerm)
Const OUT As String = "[!A-Z0-9]"
Dim rv As New Collection, pos As Long, start As Long
Dim next2 As String, next1 As String
textToSearch = UCase(" " & textToSearch & " ")
start = 1
pos = InStr(start, textToSearch, searchTerm, vbTextCompare)
Do While pos > 0
If Mid(textToSearch, pos - 1, 1) Like OUT Then
next2 = Mid(textToSearch, pos + Len(searchTerm), 2)
next1 = Left(next2, 1)
'Handle possible s at end of search term
If next1 Like OUT Or (next2 Like "S" & OUT) Then
rv.Add pos - 1
End If
End If
start = pos + 1
pos = InStr(start, textToSearch, searchTerm, vbTextCompare)
Loop
Set AllMatchesInStr = rv
End Function
Function AllMatchesRegEx(textToSearch As String, searchTerm)
Dim rv As New Collection, matches, m
Static reg As Object
If reg Is Nothing Then
Set reg = CreateObject("VBScript.RegExp")
reg.Global = True
reg.IgnoreCase = True
End If
reg.Pattern = "\b" & searchTerm & "s?\b" 'Allow for simple plural form,
'flank with word boundaries
Set matches = reg.Execute(textToSearch)
For Each m In matches
rv.Add m.firstindex + 1 'firstindex is zero-based
Next m
Set AllMatchesRegEx = rv
End Function
There is a mistake in your code:
Words = Application.Transpose(Sheets("Settings").Range("A4:A" & Dr).Text)
what is Dr?
Also don't do this:
druglastcol = Sheets("Settings").Range("A4:A" & Rows.Count).End(xlDown).Row
Do this instead:
druglastcol = Sheets("Settings").Range("A" & Rows.Count).End(xlUp).Row
The reason we do it this way is the method you have used will stop if there is a blank row in the data, the method i have posted comes from the bottom up so will always grab the true last row.
Try
Sub test()
Dim Ws As Worksheet
Dim s As String
Dim vDB
Dim i As Long
'Application.ScreenUpdating = False
Set Ws = Sheets("Settings")
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
For i = 1 To UBound(vDB, 1)
s = vDB(i, 1)
setCharacterColor s
Next i
'Application.ScreenUpdating = True
End Sub
Sub setCharacterColor(strPattern As String)
Dim mCol As Object 'MatchCollection
Dim Ws As Worksheet
Dim rngDB As Range, rng As Range
Dim s As String
Dim i As Integer, Ln As Integer
Set Ws = Sheets("Facts")
Set rngDB = Ws.Range("d1", Ws.Range("d" & Rows.Count).End(xlUp))
For Each rng In rngDB
s = rng.Value
Set mCol = GetRegEx(s, strPattern)
If Not mCol Is Nothing Then
For i = 0 To mCol.Count - 1
c = mCol.Item(i).FirstIndex + 1
Ln = mCol.Item(i).Length
With rng.Characters(c, Ln).Font
.Bold = True
.Color = vbMagenta
End With
Next i
End If
Next
End Sub
Function GetRegEx(StrInput As String, strPattern As String) As Object
Dim RegEx As Object 'New RegExp
Set RegEx = CreateObject("VBScript.RegExp") 'New RegExp
With RegEx
.Global = True
.IgnoreCase = False
.MultiLine = True
.Pattern = strPattern
End With
If RegEx.test(StrInput) Then
Set GetRegEx = RegEx.Execute(StrInput)
End If
End Function
If your use Mac then try below.
Sub test()
Dim Ws As Worksheet, WsColor As Worksheet
Dim rngDB As Range, rng As Range
Dim s As String
Dim vDB, vR
Dim i As Long, Ln As Integer
Dim j As Index
Dim st, et
Application.ScreenUpdating = False
st = Timer
Set Ws = Sheets("Settings")
Set WsColor = Sheets("Facts")
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
With WsColor
Set rngDB = .Range("d1", .Range("d" & Rows.Count).End(xlUp))
End With
For Each rng In rngDB
For i = 1 To UBound(vDB, 1)
Ln = Len(vDB(i, 1)) 'String Length
vR = getItem(rng, vDB(i, 1)) 'string startedIndex
If IsArray(vR) And Not IsEmpty(vR) Then
For j = 1 To UBound(vR)
With rng.Characters(vR(j), Ln).Font
.Bold = True
.Color = vbMagenta
End With
Next j
End If
Next i
Next rng
Application.ScreenUpdating = True
et = Timer
Debug.Print et - st
End Sub
Function getItem(rng As Range, v As Variant) As Variant
Dim vR()
Dim k As Integer, s As Integer, n As Index
Dim str As String
str = rng.Text
s = 1
Do
n = InStr(s, str, v)
If n > 0 Then
k = k + 1
ReDim Preserve vR(1 To k)
vR(k) = n
End If
s = n + Len(v)
DoEvents
Loop While n > 0
If k Then
getItem = vR
Else
getItem = Empty
End If
End Function
I need to assigned a value on Column B depending on the condition in Column A. I formulate a simple code using IF...ElseIf condition (see code below). I have 1000 conditions and I am thinking if I can use a 2 separate arrays for the value of Column A and get the index of the value in column A to 1st array (Array1 ) and match it to the 2nd array (AssignedArray). Something like, for each value found in Column A check the Array1 if the value is exist and get the index and match the index to AssignedArray. Like for example,
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
CODE
For x = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For Each wrd In Sheets(1).Cells(x, 1)
val = wrd
If UCase(val) = "DL2005" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "EFRUEN" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "DESTDIDIER" Then
Sheets(1).Cells(x, 3).Value = "Operations"
ElseIf UCase(val) = "EOGRADY3" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "EKARLSON1" Then
Sheets(1).Cells(x, 3).Value = "Analyst"
ElseIf UCase(val) = "EOKUTOMI1" Then
Sheets(1).Cells(x, 3).Value = "Operations"
End If
Next wrd
Next x
Is it possible to do that?Or is there any way on how to simplify my code instead of using IF ELSEIF condition.
If you have 1k conditions (as you do), then I imagine neither If nor Select statements are appropriate. Furthermore, creating/maintaining expressions (in your code) that evaluate to two 1k-element arrays may be burdensome.
A maintenance friendly approach might be to keep the items in Array1 on some worksheet, and keep the contents of AssignedArray right next to it. Something like the below. Say the yellow values are items that you would have put into Array1 and green values are items you would have put into AssignedArray (I only have 25 as an example).
Then you wouldn't necessarily need any VBA and could purely use Excel functions like VLOOKUP -- or MATCH and INDEX in conjunction. For example, I put this formula in cell E4, which tries to find the value in D4 among the values in column A and returns the corresponding value from column B:
=INDEX($B$1:$B$25,MATCH(D4,$A$1:$A$25,0))
If you still wanted to use VBA, this code should loop over cells D4:D8 (which is the correct range for my spreadsheet, but probably not for yours), make them uppercase (in memory only, not on the sheet), then write the corresponding values in G4:G8:
Option Explicit
Private Sub FillInAssociatedValuesValue()
Dim inputKeys() As Variant ' <-- AKA Array1
inputKeys = ThisWorkbook.Worksheets("Sheet1").Range("A1:A25").Value2 ' Change to wherever items from Array1 are kept
Dim inputValues() As Variant '<-- AKA AssignedArray
inputValues = ThisWorkbook.Worksheets("Sheet1").Range("B1:B25").Value2 ' Change to wherever items from AssignedArray are kept
If (UBound(inputKeys, 1) - LBound(inputKeys, 1)) <> (UBound(inputValues, 1) - LBound(inputValues, 1)) Then
MsgBox ("The number of keys should be the same as the number of associated values. Code will stop running now.")
Exit Sub
End If
Dim dict As Object 'Shouldn't need to add a reference
Set dict = CreateObject("Scripting.Dictionary")
' One pass to fill the dictionary. If there are duplicates, will only add first instance.
Dim rowIndex As Long
For rowIndex = LBound(inputKeys, 1) To UBound(inputKeys, 1)
If Not dict.Exists(inputKeys(rowIndex, 1)) Then
dict.Add UCase$(inputKeys(rowIndex, 1)), inputValues(rowIndex, 1)
End If
Next rowIndex
Dim Key As String
With ThisWorkbook.Worksheets("Sheet1")
For rowIndex = 4 To 8 ' I needed to loop over range D4:D8
Key = UCase$(.Cells(rowIndex, "D").Value2)
If dict.Exists(Key) Then
.Cells(rowIndex, "G").Value2 = dict.Item(Key)
Else
' Some logic in case input is not found, and cannot be mapped to some associated value
.Cells(rowIndex, "G").Value2 = "VALUE NOT FOUND"
End If
Next rowIndex
End With
End Sub
To keep it simple; use For loops to compare Array1 to each cell in column A and if there is a match, use Offset put the corresponding element from AssignedArray into the cell on the right.
Dim Array1 As Variant, AssignedArray As Variant
Dim x As Long, i As Long
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
For x = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = LBound(Array1) To UBound(Array1)
If Cells(x, 1).Value = Array1(i) Then
Cells(x, 1).Offset(, 1).Value = AssignedArray(i)
End If
Next i
Next x
Try
Sub test()
Dim Ws As Worksheet
Dim Array1, AssignedArray
Dim s As String, i As Integer, r As Long, x As Long
Dim k As Integer
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
Set Ws = Sheets(1)
r = Ws.Cells(Rows.Count, 1).End(xlUp).Row
With Ws
For x = 1 To r
s = UCase(.Cells(x, 1))
For i = LBound(Array1) To UBound(Array1)
If s = Array1(i) Then
k = i
Exit For
End If
Next i
.Cells(x, 3) = AssignedArray(k)
Next x
End With
End Sub
If you have a lot of data, it is better to speed up the results by arranging the results into a single sheet instead of entering them one by one into the cell.
Sub test2()
Dim Ws As Worksheet
Dim Array1, AssignedArray
Dim s As String, i As Integer, r As Long, x As Long
Dim k As Integer
Dim vDB, vR()
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
Set Ws = Sheets(1)
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vR(1 To r, 1 To 1)
For x = 1 To r
s = UCase(vDB(x, 1))
For i = LBound(Array1) To UBound(Array1)
If s = Array1(i) Then
k = i
Exit For
End If
Next i
vR(x, 1) = AssignedArray(k)
Next x
.Range("c1").Resize(r) = vR
End With
End Sub
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