I'm working with the worksheetfunction.averageifs() and worksheetfunction.countifs() functions.
I have some conditionals that specify what criteria should be looked for, so I'd like to just have an array that could be added new criteria to, so that instead of a series of cluttered conditionals:
If (dep = 0) Then
sortspg = True
colcount = .CountIfs(column, "<3", badCol, "1")
If (colcount > 0) Then
colavg = .AverageIfs(column, column, "<3", badCol, "1")
insert = True
Else
insert = False
End If
Else
colcount = .CountIfs(column, "<3", DepColumn, dep, badCol, "1")
If colcount > 0 Then
colavg = .AverageIfs(column, column, "<3", DepColumn, dep, badCol, "1")
insert = True
Else
insert = False
End If
End If
I could just pass an array like:
CondArray(column => "<3", DepColumn => dep)
If colCount > 0 Then
CondArray[] = (badCol => "1")
and then
.CountIfs(CondArray)
.AverageIfs(column, CondArray)
You can build it using a For...Next Loop to setup the formula, and the Evaluate function.
Sub Build_Formula()
'http://stackoverflow.com/questions/15317466/vba-excel-array-of-criteria-for-if-functions
Dim i As Long, lOutput As Long
Dim strTempArr As String
Dim CondArray() As Variant
Dim StrFormulaBuildUp As String
Dim rng As Range
'Modify constant with applicable formula worksheet function
Const STRFORMULASTART As String = "CountIfs("
'Note used this for test data; edit as applicable
Set rng = Cells.CurrentRegion
'Build array holding conditions; the way the loop is structured is for
'the "COUNTIF" function; modify as necessary
CondArray = Array(rng, "<3")
StrFormulaBuildUp = STRFORMULASTART
'Begin loop to build formula
For i = LBound(CondArray) To UBound(CondArray)
'Test if value in condition array is a range
'if yes set the range address to a string
If TypeName(CondArray(i)) = "Range" Then
strTempArr = CStr(CondArray(i).Address)
Else
'If condtion, then add quote marks
strTempArr = Chr(34) & CStr(CondArray(i)) & Chr(34)
End If
StrFormulaBuildUp = StrFormulaBuildUp & strTempArr & ","
Next i
'Remove extra "," from string and close formula
StrFormulaBuildUp = Left(StrFormulaBuildUp, Len(StrFormulaBuildUp) - 1) & ")"
'Determine forumla value
lOutput = Evaluate(StrFormulaBuildUp)
MsgBox lOutput
End Sub
Related
I have a column containing formulas as "strings", i.e. "=+I11+I192+I245+I280"
I need to replace the cells (I11, I192,I245andI280`) ID with the content (strings) contained in the cells themselves.
Example:
Cell X --> "=+I11+I192+I245+I280"
Cell I11 = 'A'
Cell I192 = 'B'
Cell I245 = 'C'
Cell I280 = 'D'
The formula should generate "=+A+B+C+D".
This?
="=+" & I11 &"+" & I192 &"+" & I245 & "+" & I280
Well, how about :
=I11 & I192 & I245 & I280
Or you can include spaces
=I11 & " " & I192
But straight quotes - my phone is being funny...
The formula should generate --> "=+A+B+C+D"
Try,
="=+"&textjoin("+", true, I11, I192, I245, I280)
Don't know what you will be doing with empty cells so here is draft
Public Sub test()
[I11] = "A": [I192] = "B": [I245] = "C": [I280] = "D"
Debug.Print ConvertedString("=+I11+I192+I245+I280")
End Sub
Public Function ConvertedString(ByVal inputString As String) As Variant
Dim arr() As String, i As Long
On Error GoTo errHand
If Not InStr(inputString, Chr$(43)) > 0 Then
ConvertedString = CVErr(xlErrNA)
Exit Function
End If
arr = Split(inputString, Chr$(43))
For i = 1 To UBound(arr)
arr(i) = Range(arr(i))
Next i
ConvertedString = Join(arr, Chr$(43))
Exit Function
errHand:
ConvertedString = CVErr(xlErrNA)
End Function
I think you mean something like
=INDIRECT(I11,TRUE)+INDIRECT(I192,TRUE)+INDIRECT(I245,TRUE)+INDIRECT(I280,TRUE)
but please note that Indirect is a volatile function, and can slow your calculations down if used extensively.
Using VBA (with only single delimiter):
Function ReplaceAddr(sInput As String, Optional sDelimiter As String = "+") As String
Dim sArr
Dim i As Long
sArr = Split(sInput, sDelimiter)
For i = 1 To UBound(sArr)
sArr = Range(sArr(i))
Next i
ReplaceAddr = Join(sArr, sDelimiter)
End Function
From OP's comment:
The problem is that formulas changes, so I can't only change manually. The one I gave you is only an example, but I have so many different ones with all math operators.
You can try finding cell addresses with regular expression and replace with cell's value:
Function ReplaceAddr2(sInput As String) As String
Dim oRegEx As Object
Dim oMatches As Object
Dim i As Long, lStart As Long, lLength As Long
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Pattern = "[A-Za-z]{1,3}\d{1,7}"
oRegEx.Global = True
oRegEx.MultiLine = True
Set oMatches = oRegEx.Execute(sInput)
lStart = 0
For i = 0 To oMatches.Count - 1
lLength = oMatches(i).FirstIndex - lStart
ReplaceAddr2 = ReplaceAddr2 & Mid$(sInput, lStart + 1, lLength) & Range(oMatches(i).Value)
lStart = lStart + lLength + oMatches(i).length
Next
ReplaceAddr2 = ReplaceAddr2 & Mid(sInput, lStart + 1, Len(sInput) - lStart)
End Function
Pattern is 1-3 letters followed by 1-7 digits.
Both functions are not volatile - will be recalculated only when input string changes, but not when cells addressed there change. Adding this line:
Application.Volatile True
will make it recalculate on every change, but it may affect performance.
I was wondering how to remove duplicate names/text's in a cell. For example
Jean Donea Jean Doneasee
R.L. Foye R.L. Foyesee
J.E. Zimmer J.E. Zimmersee
R.P. Reed R.P. Reedsee D.E. Munson D.E. Munsonsee
While googling, I stumbled upon a macro/code, it's like:
Function RemoveDupes1(pWorkRng As Range) As String
'Updateby20140924
Dim xValue As String
Dim xChar As String
Dim xOutValue As String
Set xDic = CreateObject("Scripting.Dictionary")
xValue = pWorkRng.Value
For i = 1 To VBA.Len(xValue)
xChar = VBA.Mid(xValue, i, 1)
If xDic.exists(xChar) Then
Else
xDic(xChar) = ""
xOutValue = xOutValue & xChar
End If
Next
RemoveDupes1 = xOutValue
End Function
The macro is working, but it is comparing every letter, and if it finds any repeated letters, it's removing that.
When I use the code over those names, the result is somewhat like this:
Jean Dos
R.L Foyes
J.E Zimers
R.P edsDEMuno
By looking at the result I can make out it is not what I want, yet I got no clue how to correct the code.
The desired output should look like:
Jean Donea
R.L. Foye
J.E. Zimmer
R.P. Reed
Any suggestions?
Thanks in Advance.
Input
With the input on the image:
Result
The Debug.Print output
Regex
A regex can be used dynamically iterating on the cell, to work as a Find tool. So it will extract only the shortest match. \w*( OUTPUT_OF_EXTRACTELEMENT )\w*, e.g.: \w*(Jean)\w*
The Regex's reference must be enabled.
Code
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
On Error GoTo ErrHandler:
EXTRACTELEMENT = Split(Application.Trim(Mid(Txt, 1)), Separator)(n - 1)
Exit Function
ErrHandler:
' error handling code
EXTRACTELEMENT = 0
On Error GoTo 0
End Function
Sub test()
Dim str As String
Dim objMatches As Object
Set objRegExp = CreateObject("VBScript.RegExp") 'New regexp
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For Row = 1 To lastrow
str = Range("A" & Row)
F_str = ""
N_Elements = UBound(Split(str, " "))
If N_Elements > 0 Then
For k = 1 To N_Elements + 1
strPattern = "\w*(" & EXTRACTELEMENT(CStr(str), k, " ") & ")\w*"
With objRegExp
.Pattern = strPattern
.Global = True
End With
If objRegExp.test(strPattern) Then
Set objMatches = objRegExp.Execute(str)
If objMatches.Count > 1 Then
If objRegExp.test(F_str) = False Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
ElseIf k <= 2 And objMatches.Count = 1 Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
End If
Next k
Else
F_str = str
End If
Debug.Print Trim(F_str)
Next Row
End Sub
Note that you can Replace the Debug.Print to write on the target
cell, if it is column B to Cells(Row,2)=Trim(F_str)
Explanation
Function
You can use this UDF, that uses the Split Function to obtain the element separated by spaces (" "). So it can get every element to compare on the cell.
Loops
It will loop from 1 to the number of elements k in each cell and from row 1 to lastrow.
Regex
The Regex is used to find the matches on the cell and Join a new string with the shortest element of each match.
This solution operates on the assumption that 'see' (or some other three-letter string) will always be on the end of the cell value. If that isn't the case then this won't work.
Function RemoveDupeInCell(dString As String) As String
Dim x As Long, ct As Long
Dim str As String
'define str as half the length of the cell, minus the right three characters
str = Trim(Left(dString, WorksheetFunction.RoundUp((Len(dString) - 3) / 2, 0)))
'loop through the entire cell and count the number of instances of str
For x = 1 To Len(dString)
If Mid(dString, x, Len(str)) = str Then ct = ct + 1
Next x
'if it's more than one, set to str, otherwise error
If ct > 1 Then
RemoveDupeInCell = str
Else
RemoveDupeInCell = "#N/A"
End If
End Function
I'm trying to extract text content from Excel using a macro. This is my code:
Dim i As Integer, j As Integer
Dim v1 As Variant
Dim Txt As String
v1 = Range("A2:C15")
For i = 1 To UBound(v1)
For j = 1 To UBound(v1, 2)
Txt = Txt & v1(i, j)
Next j
Txt = Txt & vbCrLf
Next i
MsgBox Txt
But it is showing the raw characters only meaning that it doesn't show any formatting information like bold, italic, underline, etc..
I want to extract the text along with the formatting information.
Example: This is sample text
Expected output: This is sample text
Actual output: This is sample text
Can someone explain what's wrong with the code and tell if anything is wrong?
A messagebox does not permit formatiing without changing system defaults, which is not a starightforward approach. If you want to display formatted text in a prompt then you are probably easiest to create a userform and format the label appropriately.
For example, you can determine if a cell has bold fomatting using:
Dim isBold As Boolean
isBold = v1(i, j).Font.Bold
And apply this to a userform label font using:
label.Font.Bold = isBold
If you want to output to a text (ie .txt) file then this cannot store any formatting information. The best you could hope to achieve is to create a markup style output where:
If isBold Then
txt = "<b >mytext< /b>" 'Ignore the spaces
Else
txt = "mytext"
End If
The range.Font.Bold property has three return options:
v1(i, j).Font.Bold = True 'if the entire cell IS bold
v1(i, j).Font.Bold = False 'if the entire cell IS NOT bold
v1(i, j).Font.Bold = Null 'if the cell is PARTIALLY bold
Calling IsNull(v1(i, j).Font.Bold) will tell you whether you have partial fomatting in a cell. Unfortunately you must then assess each character in the string individually to determine the bold characters. This function should determine where the bold formatting is switched on or off in a string contained in the Range object passed and add the appropriate markup tag:
Function markup(rng As Range) As String
Dim chr As Integer
Dim isCharBold As Boolean
Dim str As String
Dim tempChar As Characters
isCharBold = False
str = ""
If IsNull(rng.Font.Bold) Then
For chr = 1 To rng.Characters.Count
Set tempChar = rng.Characters(chr, 1)
If isCharBold Then
If tempChar.Font.Bold Then
str = str + tempChar.Text
Else
isCharBold = False
str = str & "</b>" & tempChar.Text
End If
Else
If tempChar.Font.Bold Then
isCharBold = True
str = str + "<b>" & tempChar.Text
Else
str = str & tempChar.Text
End If
End If
Next chr
Else
str = rng.Value
End If
markup = str
End Function
Notice that the Else case just returns the default string values. You can modify this approach to work for any of the .Font properties e.g. strikethrough, underline, italic....
The framework in the OP suggests that you are assigning the contents of a range of cells into an array of type Variant. This essentially leaves you with an unformatted string of characters in each array index. In this case you won't be able to extract any formatting from the array strings. To access the Characters().Font.Bold property you must be operating on a Range object so it might be best to iterate through each cell in Range("A2:C15") directly. This could be achieved by modifying your initial code as such, so it now calls the markup function:
Sub OutputText()
Dim i As Integer, j As Integer
Dim rng As Range
Dim Txt As String
Set rng = Range("A2:C15")
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
Txt = Txt & markup(rng(i, j)) & " "
Next j
Txt = Txt & vbCrLf
Next i
Debug.Print Txt
End Sub
OK, let's have the algorithm from #stucharo a little bit simpler to extend.
Public Function getHTMLFormattedString(r As Range) As String
isBold = False
isItalic = False
isUnderlined = False
s = ""
cCount = 0
On Error Resume Next
cCount = r.Characters.Count
On Error GoTo 0
If cCount > 0 Then
For i = 1 To cCount
Set c = r.Characters(i, 1)
If isUnderlined And c.Font.Underline = xlUnderlineStyleNone Then
isUnderlined = False
s = s & "</u>"
End If
If isItalic And Not c.Font.Italic Then
isItalic = False
s = s & "</i>"
End If
If isBold And Not c.Font.Bold Then
isBold = False
s = s & "</b>"
End If
If c.Font.Bold And Not isBold Then
isBold = True
s = s + "<b>"
End If
If c.Font.Italic And Not isItalic Then
isItalic = True
s = s + "<i>"
End If
If Not (c.Font.Underline = xlUnderlineStyleNone) And Not isUnderlined Then
isUnderlined = True
s = s + "<u>"
End If
s = s & c.Text
If i = cCount Then
If isUnderlined Then s = s & "</u>"
If isItalic Then s = s & "</i>"
If isBold Then s = s & "</b>"
End If
Next i
Else
s = r.Text
If r.Font.Bold Then s = "<b>" & s & "</b>"
If r.Font.Italic Then s = "<i>" & s & "</i>"
If Not (r.Font.Underline = xlUnderlineStyleNone) Then s = "<u>" & s & "</u>"
End If
getHTMLFormattedString = s
End Function
To be clear, this function works only with a range containing a single cell. But it should be easy calling this function for each cell in a bigger range and concatenating the returned strings into one.
Edit by the OP:
I called the function by the below code:
Sub ReplaceFormattingTags()
Dim i As Integer, j As Integer
Dim rng As Range
Dim Txt As String
Set rng = Range("A2:C15")
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
Txt = Txt & getHTMLFormattedString(rng(i, j)) & " "
Next j
Txt = Txt & vbCrLf
Next i
Debug.Print Txt
End Sub
VBA string does not support formatting like that. It will purely take the string from the range. No formatting at all. If you want to format the string, you can not see this through msgbox.
Only way to do it would be to store it in a cell then format the cell. But then that does not give you the output in a messagebox as a formatted string.
If you are planning to then put the string in a cell with formatting, you will need to save the formatting somewhere, or copy it from the cell you got the text from. And then apply the formatting to the cell
I need to sync up the values in the curly braces {} found in column C and put them against the user id in column F as seen below.
E.g. on the Emails sheet
becomes this on a new sheet
Sub CopyConditional()
Dim wshS As Worksheet
Dim WhichName As String
Set wshS = ActiveWorkbook.Sheets("Emails")
WhichName = "NewSheet"
Const NameCol = "C"
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim wshT As Worksheet
Dim cpt As String
Dim user As String
Dim computers() As String
Dim computer As String
On Error Resume Next
Set wshT = Worksheets(WhichName)
If wshT Is Nothing Then
Set wshT = Worksheets.Add(After:=wshS)
wshT.Name = WhichName
End If
On Error GoTo 0
If wshT.Cells(1, NameCol).value = "" Then
TrgRow = 1
Else
TrgRow = wshT.Cells(wshT.Rows.Count, NameCol).End(xlUp).Row + 1
End If
LastRow = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
cpt = wshS.Range("C" & SrcRow).value
user = wshS.Range("F" & SrcRow).value
If InStr(cpt, ":") Then
cpt = Mid(cpt, InStr(1, cpt, ":") + 1, Len(cpt))
End If
If InStr(cpt, ";") Then
computers = Split(cpt, ";")
For i = 0 To UBound(computers)
If computers(i) <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computers(i), Len(computers(i)) - 1), 2)
TrgRow = TrgRow + 1
End If
Next
Else
computer = cpt
If computer <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computer, Len(computer) - 1), 2)
TrgRow = TrgRow + 1
End If
End If
Next SrcRow
End Sub
I managed to resolve it with the above code but there are 3 niggling issues:
1) The first curly brace is always copied, how do I omit this so something like {Computer1 looks like Computer 1
2) Where there are two computers in a row, then the output looks something like this:
when it should really be split into two different rows i.e.
User 1 | Computer 1
User 1 | Computer 2
3) If there is text after the last curly brace with text in it e.g. {Computer1};{Computer2};Request submitted then that text is added as a new row, I don't want this, I want it to be omitted e.g.
should just be:
User 1 | Computer 1
User 1 | Computer 2
How do I go about rectifying these issues?
Try this:
Sub Collapse()
Dim uRng As Range, cel As Range
Dim comps As Variant, comp As Variant, r As Variant, v As Variant
Dim d As Dictionary '~~> Early bind, for Late bind use commented line
'Dim d As Object
Dim a As String
With Sheet1 '~~> Sheet that contains your data
Set uRng = .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
End With
Set d = CreateObject("Scripting.Dictionary")
With d
For Each cel In uRng
a = Replace(cel.Offset(0, -3), "{", "}")
comps = Split(a, "}")
Debug.Print UBound(comps)
For Each comp In comps
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then '~~> I assumed max Comp# is 99
If Not .Exists(cel) Then
.Add cel, comp
Else
If IsArray(.Item(cel)) Then
r = .Item(cel)
ReDim Preserve r(UBound(r) + 1)
r(UBound(r)) = comp
.Item(cel) = r
Else
r = Array(.Item(cel), comp)
.Item(cel) = r
End If
End If
End If
Next
Next
End With
For Each v In d.Keys
With Sheet2 '~~> sheet you want to write your data to
If IsArray(d.Item(v)) Then
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = Application.Transpose(d.Item(v))
Else
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = d.Item(v)
End If
End With
Next
Set d = Nothing
End Sub
Above code uses Replace and Split Function to pass your string to array.
a = Replace(cel.Offset(0, -3), "{", "}") '~~> standardize delimiter
comps = Split(a, "}") '~~> split using standard delimiter
Then information are passed to dictionary object using User as key and computers as items.
We filter the items passed to dictionary using Instr and Len Function
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then
As I've commented, I assumed your max computer number is 99.
Else change 10 to whatever length you need to check.
Finally we return the dictionary information to the target worksheet.
Note: You need to add reference to Microsoft Scripting Runtime if you prefer early bind
Result: I tried it on a small sample data patterned on how I see it in you SS.
So assuming you have this data in Sheet1:
Will output data in Sheet2 like this:
I use a custom parse function for this type of operation:
Sub CopyConditional()
' some detail left out
Dim iRow&, Usern$, Computer$, Computers$
For iRow = ' firstrow To lastrow
Usern = Sheets("Emails").Cells(iRow, "F")
Computers = Sheets("Emails").Cells(iRow, "C")
Do
Computer = zParse(Computers) ' gets one computer
If Computer = "" Then Exit Do
' Store Computer and Usern
Loop
Next iRow
End Sub
Function zParse$(Haystack$) ' find all {..}
Static iPosL& '
Dim iPosR&
If iPosL = 0 Then iPosL = 1
iPosL = InStr(iPosL, Haystack, "{") ' Left
If iPosL = 0 Then Exit Function ' no more
iPosR = InStr(iPosL, Haystack, "}") ' Right
If iPosR = 0 Then MsgBox "No matching }": Stop
zParse = Mid$(Haystack, iPosL + 1, iPosR - iPosL - 1)
iPosL = iPosR
End Function
1) Use the Mid function to drop the first character:
str = "{Computer1"
str = Mid(str,2)
now str = "Computer1"
2) You can use the Split function to separate these out and combine with the Mid function above
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
result = Mid(splt(a),2)
next a
3) Add a conditional statement to the above loop
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
if Left(splt(a),1) = "{" then result = Mid(splt(a),2)
next a
Use this loop and send each result to the desired cell (in the for-next loop) and you should be good to go.
I am looking for a method to compare a list of cell values to a certain reference value. If I would only need to compare the values I'd know how to achieve that. But here is the kicker: How can I look for a partial match? e.g.: the reference value should be "good". If the value of those cells would be "good" as well it should be considered a match. If the cell value is "Mr. goodcat" it should also be considered a match. My best guess would be to reference the original value to a string variable and put in some "*" if that would be possible.
Since I am not able to post some code, I don't need you to give me the whole answer, but a point in the right direction would be very nice. Thanks in advance guys.
edit: I have put in my final code. A short explaination: It loops through values in Sheet2 and compares them to values in column J in Sheet 1. If it finds a (partial) match, it highlights the cell.
Sub CompareValues()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws1Lrow As Long
Dim ws2Lrow As Long
Dim i As Integer
Dim x As Integer
Dim k As Integer
Dim reference As String
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
ws1Lrow = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row
ws2Lrow = Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To ws2Lrow Step 1
ws2.Select
Cells(i, 1).Select
reference = ActiveCell
ws1.Select
For x = 2 To ws1Lrow
k = InStr(1, Cells(x, 10), reference, vbTextCompare)
If k > 0 Then
Cells(x, 10).Interior.ColorIndex = 6
End If
Next x
Next i
End Sub
How about this?
Dim I As Integer
I = InStr(1, "Mr. goodcat", "good", vbTextCompare)
If I > 0 Then
' Match
Else
' No Match
End
Here's more advanced function which allows wildcards in the middle:
Function PatternMatch(ByVal SearchIn As String, ByVal Pattern As String) As Boolean
If Len(SearchIn) = 0 Or Len(Pattern) = 0 Then
PatternMatch = False
Exit Function
End If
Dim Position As Integer
Dim MatchFirst As Boolean
Dim MatchLast As Boolean
Dim Chunks() As String
MatchFirst = (Left(Pattern, 1) <> "*")
MatchLast = (Right(Pattern, 1) <> "*")
Chunks = Split(Pattern, "*")
LastChunkIndex = UBound(Chunks)
If MatchFirst Then
If Not (Left(SearchIn, Len(Chunks(0))) = Chunks(0)) Then
PatternMatch = False
Exit Function
End If
End If
If MatchLast Then
If Not (Right(SearchIn, Len(Chunks(LastChunkIndex))) = Chunks(LastChunkIndex)) Then
PatternMatch = False
Exit Function
End If
End If
Position = 1
For Each Chunk In Chunks
ChunkLength = Len(Chunk)
If ChunkLength > 0 Then
NextPosition = InStr(Position, SearchIn, Chunk, vbTextCompare)
If NextPosition > 0 And NextPosition >= Position Then
Position = NextPosition + ChunkLength
Else
PatternMatch = False
Exit Function
End If
End If
Next Chunk
PatternMatch = True
End Function