Search cell for text and copy text to another cell in VBA? - vba

I've got a column which contains rows that have parameters in them. For example
W2 = [PROD][FO][2.0][Customer]
W3 = [PROD][GD][1.0][P3]
W4 = Issues in production for customer
I have a function that is copying other columns into another sheet, however for this column, I need to do the following
Search the cell and look for [P*]
The asterisk represents a number between 1 and 5
If it finds [P*] then copy P* to the sheet "Calculations" in column 4
Basically, remove everything from the cell except where there is a square bracket, followed by P, a number and a square bracket
Does anyone know how I can do this? Alternatively, it might be easier to copy the column across and then remove everything that doesn't meet the above criteria.

Second Edit:
I edited here to use a regular expression instead of a loop. This may be the most efficient method to achieve your goal. See below and let us know if it works for you:
Function MatchWithRegex(sInput As String) As String
Dim oReg As Object
Dim sOutput As String
Set oReg = CreateObject("VBScript.RegExp")
With oReg
.Pattern = "[[](P[1-5])[]]"
End With
If oReg.test(sInput) Then
sOutput = oReg.Execute(sInput)(0).Submatches(0)
Else
sOutput = ""
End If
MatchWithRegex = sOutput
End Function
Sub test2()
Dim a As String
a = MatchWithRegex(Range("A1").Value)
If a = vbNullString Then
MsgBox "None"
Else
MsgBox MatchWithRegex(Range("A1").Value)
End If
End Sub
First EDIT:
My solution would be something as follows. I'd write a function that first tests if the Pattern exists in the string, then if it does, I'd split it based on brackets, and choose the bracket that matches the pattern. Let me know if that works for you.
Function ExtractPNumber(sInput As String) As String
Dim aValues
Dim sOutput As String
sOutput = ""
If sInput Like "*[[]P[1-5][]]*" Then
aValues = Split(sInput, "[")
For Each aVal In aValues
If aVal Like "P[1-5][]]*" Then
sOutput = aVal
End If
Next aVal
End If
ExtractPNumber = Left(sOutput, 2)
End Function
Sub TestFunction()
Dim sPValue As String
sPValue = ExtractPNumber(Range("A2").Value)
If sPValue = vbNullString Then
'Do nothing or input whatever business logic you want
Else
Sheet2.Range("A1").Value = sPValue
End If
End Sub
OLD POST:
In VBA, you can use the Like Operator with a Pattern to represent an Open Bracket, the letter P, any number from 1-5, then a Closed Bracket using the below syntax:
Range("A1").Value LIke "*[[]P[1-5][]]*"

EDIT: Fixed faulty solution
If you're ok with blanks and don't care if *>5, I would do this and copy down column 4:
=IF(ISNUMBER(SEARCH("[P?]",FirstSheet!$W2)), FirstSheet!$W2, "")
Important things to note:
? is the wildcard symbol for a single character; you can use * if you're ok with multiple characters at that location
will display cell's original value if found, leave blank otherwise
Afterwards, you can highlight the column and remove blanks if needed. Alternatively, you can replace the blank with a placeholder string.
If * must be 1-5, use two columns, E and D, respectively:
=MID(FirstSheet!$W2,SEARCH("[P",FirstSheet!$W2)+2,1)
=IF(AND(ISNUMBER($E2),$E2>0,$E2<=5,MID($W2,SEARCH("[P",FirstSheet!$W2)+3,1))), FirstSheet!$W2, "")
where FirstSheet is the name of your initial sheet.

Related

Excel cell content validation with use of VBA code

I am looking for a solution to validate and highlight my cell in case false.
I tried the most promising solution: Regex. But still can not find the pattern I need.
My latest attempt was this pattern: "[A-Z-0-9_.]" This works only if the cell contains only a symbol and nothing else, if the symbol is part of a string it does not work.
Problem is that it does not catch cells that have an odd character in a string of text: Example C4UNIT| or B$GROUP.
Specification Cell can contain only capital characters and two allowed symbols Dash - and Underbar _
This is my complete code:
Function ValidateCellContent()
Sheets("MTO DATA").Select
Dim RangeToCheck As Range
Dim CellinRangeToCheck As Range
Dim CollNumberFirst As Integer
Dim CollNumberLast As Integer
Dim RowNumberFirst As Integer
Dim RowNumberLast As Integer
'--Start on Column "1" and Row "3"
CollNumberFirst = 1
RowNumberFirst = 3
'--Find last Column used on row "2" (Write OMI Headings)
CollNumberLast = Cells(2, Columns.count).End(xlToLeft).Column
RowNumberLast = Cells(Rows.count, 1).End(xlUp).Row
'--Set value of the used range of cell addresses like: "A3:K85"
Set RangeToCheck = Range(Chr(64 + CollNumberFirst) & RowNumberFirst & ":" & Chr(64 + CollNumberLast) & RowNumberLast)
Debug.Print "Cells used in active Range = " & (Chr(64 + CollNumberFirst) & RowNumberFirst & ":" & Chr(64 + CollNumberLast) & RowNumberLast)
For Each CellinRangeToCheck In RangeToCheck
Debug.Print "CellinRangeToCheck value = " & CellinRangeToCheck
If Len(CellinRangeToCheck.Text) > 0 Then
'--Non Printables (Space,Line Feed,Carriage Return)
If InStr(CellinRangeToCheck, " ") _
Or InStr(CellinRangeToCheck, Chr(10)) > 0 _
Or InStr(CellinRangeToCheck, Chr(13)) > 0 Then
CellinRangeToCheck.Font.Color = vbRed
CellinRangeToCheck.Font.Bold = True
'--Allowed Characters
ElseIf Not CellinRangeToCheck.Text Like "*[A-Z-0-9_.]*" Then
CellinRangeToCheck.Font.Color = vbRed
CellinRangeToCheck.Font.Bold = True
Else
CellinRangeToCheck.Font.Color = vbBlack
CellinRangeToCheck.Font.Bold = False
End If
End If
Next CellinRangeToCheck
End Function
Try this:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'we want only validate when cell content changed, if whole range is involved (i.e. more than 1 cell) then exit sub
If Target.Cells.Count > 1 Then Exit Sub
'if there is error in a cell, also color it red
If IsError(Target) Then
Target.Interior.ColorIndex = 3
Exit Sub
End If
'validate cell with our function, if cell content is valid, it'll return True
'if it i s not valid, then color cell red
If Not ValidateText(Target.Value) Then
Target.Interior.ColorIndex = 3
End If
End Sub
Function ValidateText(ByVal txt As String) As Boolean
Dim i As Long, char As String
'loop through all characters in string
For i = 1 To Len(txt)
char = Mid(txt, i, 1)
If Not ((Asc(char) >= 65 And Asc(char) <= 90) Or char = "-" Or char = "_") Then
'once we come upon invalid character, we can finish the function with False result
ValidateText = False
Exit Function
End If
Next
ValidateText = True
End Function
I've originally assumed you wanted to use RegEx to solve your problem. As per your comment you instead seem to be using the Like operator.
Like operator
While Like accepts character ranges that may resemble regular expressions, there are many differences and few similarities between the two:
Like uses ! to negate a character range instead of the ^ used in RegEx.
Like does not allow/know quantifiers after the closing bracket ] and thus always matches a single character per pair of brackets []. To match multiple characters you need to add multiple copies of your character range brackets.
Like does not understand advanced concepts like capturing groups or lookahead / lookbehind
probably more differences...
The unavailability of quantifiers leaves Like in a really bad spot for your problem. You always need to have one character range to compare to for each character in your cell's text. As such the only way I can see to make use of the Like operator would be as follows:
Private Function IsTextValid(ByVal stringToValidate As String) As Boolean
Dim CharValidationPattern As String
CharValidationPattern = "[A-Z0-9._-]"
Dim StringValidationPattern As String
StringValidationPattern = RepeatString(CharValidationPattern, Len(stringToValidate))
IsTextValid = stringToValidate Like StringValidationPattern
End Function
Private Function RepeatString(ByVal stringToRepeat As String, ByVal repetitions As Long) As String
Dim Result As String
Dim i As Long
For i = 1 To repetitions
Result = Result & stringToRepeat
Next i
RepeatString = Result
End Function
You can then pass the text you want to check to IsTextValid like that:
If IsTextValid("A.ASDZ-054_93") Then Debug.Print "Hurray, it's valid!"
As per your comment, a small Worksheet_Change event to place into the worksheet module of your respective worksheet. (You will also need to place the above two functions there. Alternatively you can make them public and place them in a standard module.):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ValidationRange As Range
Set ValidationRange = Me.Range("A2:D5")
Dim TargetCell As Range
For Each TargetCell In Target.Cells
' Only work on cells falling into the ValidationRange
If Not Intersect(TargetCell, ValidationRange) Is Nothing Then
If IsTextValid(TargetCell.Text) Then
TargetCell.Font.Color = vbBlack
TargetCell.Font.Bold = False
Else
TargetCell.Font.Color = vbRed
TargetCell.Font.Bold = True
End If
End If
Next TargetCell
End Sub
Regular Expressions
If you want to continue down the RegEx road, try this expression:
[^A-Z0-9_-]+
It will generate a match, whenever a passed-in string contains one or more characters you don't want. All cells with only valid characters should not return a match.
Explanation:
A-Z will match all capital letters,
0-9 will match all numbers,
_- will match underscore and dash symbols.
The preceding ^ will negate the whole character set, meaning the RegEx only matches characters not in the set.
The following + tells the RegEx engine to match one or more characters of the aforementioned set. You only want to match your input, if there is at least one illegal char in there. And if there are more than one, it should still match.
Once in place, adapting the system to changing requirements (different chars considered legal) is as easy as switching out a few characters between the [brackets].
See a live example online.

How to VBA Excel Macro part of a string

I'm currently busy with Excel tooling and learning a lot but i got a question. Currently i have a couple rows with data in the rows. In the rows there is a lot of data but i need a specific part of the row. Of course i can delete it all manually but to do that for 3000 rows i will be wasting a lot of time.
Can any one help me with a macro that filters data. The data i need is between [ and ] so for example [data]
I hope you guys can help me out and if you need more information just ask me! I hope you guys can help me!
Example String ROW:
[Sandwitch]><xsd:element name="T8436283"
So what do i need?
So i need a macro that only gets the Sandwitch out of it and paste it in the B column. The string with all the information stays at column A and the Sandwitch goes to Column B and that for all rows.
Option 1: Find/Replace
1) Copy data in another column (just saving original copy)
2) Perform Find/Replace "*["
3) Perform Find/Replace "]"
Now you have data which was between [].
Option 2: Use formulas
1) Lets assume that original data in Column "A"
2) Apply this formula in column "B" which will extract data between []
=MID(A1,FIND("[",A1)+1,FIND("]",A1)-FIND("[",A1)-1)
Option 3: Macro
If it is absolutely needed, I can help create a macro, otherwise try first two easier options.
A general purpose "find element in s starting x up to next y":
Function GenExtract(FromStr As String, _
StartSep As String, EndSep As String) _
As Variant
Dim StPos As Long
Dim EnPos As Long
GenExtract = CVErr(xlErrNA)
If StartSep = "" Or EndSep = "" Then Exit Function 'fail
StPos = InStr(1, FromStr, Left(StartSep, 1))
If StPos = 0 Or StPos = Len(FromStr) Then Exit Function 'fail
EnPos = InStr(StPos + 1, FromStr, Left(EndSep, 1))
If EnPos = 0 Then Exit Function 'fail
GenExtract = Mid(FromStr, StPos + 1, EnPos - StPos - 1)
End Function
If the two separators are the same, as per quotes, it gives the first string enclosed by those.
If you want to get your feet wet in Regular Expressions, the following code will take you there. You have to add a reference to the VB Scripting Library
Tools > References > Microsoft VBScript Regular Expressions 5.5
Then the code is as follows:
Sub textBetweenStuffs()
Dim str As String
Dim regEx As RegExp
Dim m As Match
Dim sHolder As MatchCollection
Dim bracketCollection As Collection
Dim quoteCollection As Collection
Set regEx = New RegExp
'Matches anything in between an opening bracket and first closing bracket
regEx.Pattern = "\[(.*?\])"
str = "[Sandwitch]><xsd:element name=""T8436283"""
'populates matches into match collection
Set sHolder = regEx.Execute(str)
Set bracketCollection = New Collection
'loop through values in match collection to do with as you wish
For Each m In sHolder
bracketCollection.Add m.Value
Next i
Set sHolder = Nothing
'get values between Quotations
regEx.Pattern = "\"(.*?\")"
'populates matches into match collection
Set sHolder = regEx.Execute(str)
Set quoteCollection = New Collection
'loop through values in match collection to do with as you wish
For Each m In sHolder
quoteCollection.Add m.Value
Next i
End Sub

Range.Find() text with carriage return Excel VBA

What I'm trying to do
Locate the column whose header cell contains a unique string. In other words, I know the cell's text, and I know the cell is in row 1, but I don't know which column. NOTE: I want to search for the entire text, not just part of it. NOTE2: The text can vary, so I cannot hardcode the value into my code. Rather I need to use the variable in which the value is stored.
The problem
When there's no carriage return in the header text, a simple newCol = Range("1:1").Find(headerText).Column works fine. However, if there is a carriage return, this doesn't work. It throws up the error "Object variable or With block variable not set". Here's my exact header string:
Incomplete Email
(more text)
What I've already tried
I also tried using WorksheetFunction.Match(headerText, Range("1:1"), 0), but got the same issue.
Additional notes and requirements
This is part of an add-in, so I do not want to change anything in the user's excel sheet if I don't have to (i.e., I don't want to remove the carriage return).
Technically, I'm doing this in a function:
Public Function getColumn(headerText As Variant)
getColumn = Range("1:1").Find(headerText).Column
End Function
Thanks!
pls try with below code
Public Function getColumn(headerText As String)
str1 = Split(headerText, vbCrLf)
str2 = UBound(str1)
b = Range("1:1").Find(str1(0) & Chr(10) & str1(1)).Column
End Function
Here's the thing: text with and without line break is NOT the same text hence the .Find fail. What you should do is a pattern lookup. I have just tested this and it works, provided that if there is no line break there shall be a space:
Sub test()
Dim rex As RegExp, ran As Range
Dim col As Integer, headerText As String
'read you headerText here
Set rex = New RegExp
rex.Pattern = RegexIt(headerText)
For Each ran In Range("1:1")
If rex.test(ran.Text) Then
col = ran.Column
Exit For
End If
Next ran
MsgBox col
End Sub
Function RegexIt(what As String) As String
what = Replace(what, "(", "\(")
what = Replace(what, ")", "\)")
what = Replace(what, "[", "\[")
what = Replace(what, "]", "\]")
what = Replace(what, "<", "\<")
what = Replace(what, ">", "\>")
what = Replace(what, " ", "[\n ]?")
what = Replace(what, vbCrLf, "[\n ]?")
End Function
Good luck!
Edit: Reference to Microsoft VBScript Regular Expressions 5.5 required
Edit2: Edited for variable use. Explanation: Replace space in variable value with optionel space/line break, escape brackets for pattern matching.
Your code should work even if the header cell contains carriage returns:
Sub FindColumnWithTextInRowOne()
Dim headerText As String, newCol As Long
headerText = "whatever"
newCol = Range("1:1").Find(headerText).Column
MsgBox newCol
End Sub
This is because your use of Find() does not require a match to the WHOLE contents of the cell.
EDIT#1:
If the header cell was constructed using a formula, then a slightly different Find() should be used:
Sub FindColumnWithTextInRowOne()
Dim headerText As String, newCol As Long, r As Range
headerText = Range("H1").Text
newCol = Range("1:1").Find(What:=headerText, LookAt:=xlWhole, LookIn:=xlValues).Column
MsgBox newCol
End Sub

How to extract specific text from a cell?

In this case, I want to extract the beginning text in a cell and leave the remainder intact.
e.g. a series of cells contain:
2nd Unit. Miami
3rd Production Staff. Toronto
1st Ad. San Francisco
I want to break this up without using Text to columns as previous rows are formatted differently and these last few rows are outliers that I want to handle.
I thought Regular Expressions might do it, but that seems a bit complex.
My algorithm idea is:
1. grab the wanted text (what function or custom sub would do that?)
2. Past the text to it's new location
3. Cut the text from the cell, leaving the remaining text.
Seems simple but I'm still wending my way through VBA forest, and at the rate I'm going it's going to end up faster doing it by hand. But this seems like a good opportunity to learn some VBA tricks.
TIA
Update:
I want to take the text up to the ".\ " and move it to a different column, keeping the remainder where it is.
VBA is unnecessary. To get the text after .\ in cell A1: =MID(A1,FIND(".\",A1,1)+2,LEN(A1)) to get the text before .\ in A1: =LEFT(A1,FIND(".\",A1,1)-1).
As additional information, Find returns the placement in the string where .\ appears. It is the equivalent of InStr in VBA. If .\ is not in the cell, it will display #VALUE, because I didn't bother to add error checking.
Since you seem to want to modify the cell text in place, VBA will be required.
Inside a loop that sets cl to the cell to be processed:
str = cl.value
i = Instr(str, ".\")
cl = Trim(Mid$(str, i + 2)) ' assuming you want to exclude the ".\"
cl.Offset(0, 1) Trim(Left$(str, i - 1)) ' Places the original first part one cell to the right
For the sake of anyone who had this same question, here is the fully tested, working code.
Function RE6(strData As String) As String
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "[0-9][0-9][0-9][0-9]B"
RE6 = .test(strData)
End With
Set REMatches = RE.Execute(strData)
If REMatches.Count > 0 Then
RE6 = True
Else
RE6 = False
End If
End Function
Sub territory()
Dim strTest As String, str As String, cl As Range
strTest = ActiveCell.Value
Set cl = ActiveCell
If RE6(strTest) = True Then
str = cl.Value
i = InStr(str, ". ")
cl = Trim(Mid$(str, i + 2))
cl.Offset(0, 1) = Trim(Left(str, i - 1))
cl.Offset(0, 2) = "Instance"
MsgBox RE6(strTest)
End If
End Sub

How to normalize filenames listed in a range

I have a list of filenames in a spreadsheet in the form of "Smith, J. 010112.pdf". However, they're in the varying formats of "010112.pdf", "01.01.12.pdf", and "1.01.2012.pdf". How could I change these to one format of "010112.pdf"?
Personally I hate using VBA where worksheet functions will work, so I've worked out a way to do this with worksheet functions. Although you could cram this all into one cell, I've broken it out into a lot of independent steps in separate columns so you can see how it's working, step by step.
For simplicity I'm assuming your file name is in A1
B1 =LEN(A1)
determine the length of the filename
C1 =SUBSTITUTE(A1," ","")
replace spaces with nothing
D1 =LEN(C1)
see how long the string is if you replace spaces with nothing
E1 =B1-D1
determine how many spaces there are
F1 =SUBSTITUTE(A1," ",CHAR(8),E1)
replace the last space with a special character that can't occur in a file name
G1 =SEARCH(CHAR(8), F1)
find the special character. Now we know where the last space is
H1 =LEFT(A1,G1-1)
peel off everything before the last space
I1 =MID(A1,G1+1,255)
peel off everything after the last space
J1 =FIND(".",I1)
find the first dot
K1 =FIND(".",I1,J1+1)
find the second dot
L1 =FIND(".",I1,K1+1)
find the third dot
M1 =MID(I1,1,J1-1)
find the first number
N1 =MID(I1,J1+1,K1-J1-1)
find the second number
O1 =MID(I1,K1+1,L1-K1-1)
find the third number
P1 =TEXT(M1,"00")
pad the first number
Q1 =TEXT(N1,"00")
pad the second number
R1 =TEXT(O1,"00")
pad the third number
S1 =IF(ISERR(K1),M1,P1&Q1&R1)
put the numbers together
T1 =H1&" "&S1&".pdf"
put it all together
It's kind of a mess because Excel hasn't added a single new string manipulation function in over 20 years, so things that should be easy (like "find last space") require severe trickery.
Here's a screenshot of a simple four-step method based on Excel commands and formulas, as suggested in a comment to the answered post (with a few changes)...
This function below works. I've assumed that the date is in ddmmyy format, but adjust as appropriate if it's mmddyy -- I can't tell from your example.
Function FormatThis(str As String) As String
Dim strDate As String
Dim iDateStart As Long
Dim iDateEnd As Long
Dim temp As Variant
' Pick out the date part
iDateStart = GetFirstNumPosition(str, False)
iDateEnd = GetFirstNumPosition(str, True)
strDate = Mid(str, iDateStart, iDateEnd - iDateStart + 1)
If InStr(strDate, ".") <> 0 Then
' Deal with the dot delimiters in the date
temp = Split(strDate, ".")
strDate = Format(DateSerial( _
CInt(temp(2)), CInt(temp(1)), CInt(temp(0))), "ddmmyy")
Else
' No dot delimiters... assume date is already formatted as ddmmyy
' Do nothing
End If
' Piece it together
FormatThis = Left(str, iDateStart - 1) _
& strDate & Right(str, Len(str) - iDateEnd)
End Function
This uses the following helper function:
Function GetFirstNumPosition(str As String, startFromRight As Boolean) As Long
Dim i As Long
Dim startIndex As Long
Dim endIndex As Long
Dim indexStep As Integer
If startFromRight Then
startIndex = Len(str)
endIndex = 1
indexStep = -1
Else
startIndex = 1
endIndex = Len(str)
indexStep = 1
End If
For i = startIndex To endIndex Step indexStep
If Mid(str, i, 1) Like "[0-9]" Then
GetFirstNumPosition = i
Exit For
End If
Next i
End Function
To test:
Sub tester()
MsgBox FormatThis("Smith, J. 01.03.12.pdf")
MsgBox FormatThis("Smith, J. 010312.pdf")
MsgBox FormatThis("Smith, J. 1.03.12.pdf")
MsgBox FormatThis("Smith, J. 1.3.12.pdf")
End Sub
They all return "Smith, J. 010312.pdf".
You don't need VBA. Start by replacing the "."s with nothing:
=SUBSTITUTE(A1,".","")
This will change the ".PDF" to "PDF", so let's put that back:
=SUBSTITUTE(SUBSTITUTE(A1,".",""),"pdf",".pdf")
Got awk? Get the data into a text file, and
awk -F'.' '{ if(/[0-9]+\.[0-9]+\.[0-9]+/) printf("%s., %02d%02d%02d.pdf\n", $1, $2, $3, length($4) > 2 ? substr($4,3,2) : $4); else print $0; }' your_text_file
Assuming the data are exactly as what you described, e.g.,
Smith, J. 010112.pdf
Mit, H. 01.02.12.pdf
Excel, M. 8.1.1989.pdf
Lec, X. 06.28.2012.pdf
DISCLAIMER:
As #Jean-FrançoisCorbett has mentioned, this does not work for "Smith, J. 1.01.12.pdf". Instead of reworking this completely, I'd recommend his solution!
Option Explicit
Function ExtractNumerals(Original As String) As String
'Pass everything up to and including ".pdf", then concatenate the result of this function with ".pdf".
'This will not return the ".pdf" if passed, which is generally not my ideal solution, but it's a simpler form that still should get the job done.
'If you have varying extensions, then look at the code of the test sub as a guide for how to compensate for the truncation this function creates.
Dim i As Integer
Dim bFoundFirstNum As Boolean
For i = 1 To Len(Original)
If IsNumeric(Mid(Original, i, 1)) Then
bFoundFirstNum = True
ExtractNumerals = ExtractNumerals & Mid(Original, i, 1)
ElseIf Not bFoundFirstNum Then
ExtractNumerals = ExtractNumerals & Mid(Original, i, 1)
End If
Next i
End Function
I used this as a testcase, which does not correctly cover all your examples:
Sub test()
MsgBox ExtractNumerals("Smith, J. 010112.pdf") & ".pdf"
End Sub