I have a headscratcher here. Quick background, I "inherited" a pretty complex (to my standards) macro (see attached code, this is just a piece of it!) and I'm encountering an issue where, some files return a "13 mismatch." when I go into debug mode it highlights the following portion of the script:
Quantity = LineSplit(NumCPUPos) <- located around line 130 assuming the formatting stayed the same
The interesting thing is that this doesn't happen to other files where the data is roughly the same (only the numbers are different). Even more interesting, if I take the file that gave me this debug error and just copy->paste the information back into the same file and save it...then the macro will run without any errors.
Any thoughts on A) why? and B) how to fix?
Sub ProcessHostExport(ByVal file As String)
Dim line As String
Dim LineCount As Double
Dim LineSplit As Variant
Dim hostPos As Integer, UsagePos As Integer, productPos As Integer, LicensePos As Integer, CenterPos As Integer
Dim NumCPUPos As Integer, keyPos As Integer, metricPos As Integer, clusterPos As Integer, NumCorePos As Integer, vmPos As Integer
Dim Host As String, Usage As Variant, Product As String, License As String, Center As String
Dim Quantity As Integer, Metric As String, Cluster As String, Key As String, NumCPU As Integer, NumCore As Integer, VM As Integer
Dim RegEx As Object
Dim Matches As Object
' Reset the flags
VI3Flag = False
MetricFlag = False
MissingFlag = False
DupeFlag = False
' Setup RegEx
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Pattern = "(""[^""]*"")|([^,]*)"
RegEx.Global = True
' Open file as line input and loop through lines
Open file For Input As #2
LineCount = 0
Do Until EOF(2)
' Read line
LineCount = LineCount + 1
Line Input #2, line
' Check for empty row or if row starts with non-alphanumeric characters
If Trim(line) = "" Then Exit Do
' Replace tabs with commas in the line if needed
If InStr(1, line, Chr(9)) <> 0 Then line = Replace(line, Chr(9), ",")
' Correct headers
If LineCount = 1 Then
If InStr(1, UCase(line), "SERVER SYSTEM") <> 0 Then line = Replace(UCase(line), "SERVER SYSTEM", "SERVER")
If InStr(1, UCase(line), "ASSET") <> 0 Then line = Replace(UCase(line), "ASSET", "HOST")
If InStr(1, UCase(line), "NAME") <> 0 Then line = Replace(UCase(line), "NAME", "HOST")
If InStr(1, UCase(line), "LICENSEKEY") <> 0 Then line = Replace(UCase(line), "LICENSEKEY", "LICENSE KEY")
End If
' Split the line to an array
LineSplit = Split(line, ",")
If UBound(LineSplit) >= 2 Then
' If the line is the header
If LineCount = 1 Then
' Verify that file is a csv
If UBound(LineSplit) = 0 Then
ThisWorkbook.Sheets("File Log").Cells(logRow, 3) = "ERROR: Records are not comma separated"
ThisWorkbook.Sheets("File Log").Cells(logRow, 3).Interior.ColorIndex = 3
End If
' Check for non-alphanumeric characters at the beginning of the file
Do While InStr(1, ALLCHARS, Left(line, 1)) = 0
line = Right(line, Len(line) - 1)
Loop
' Remove double quotes around entries
line = Replace(line, Chr(34), "")
' Get header positions
hostPos = GetHeaderPosition(line, "HOST")
productPos = GetHeaderPosition(line, "PRODUCT")
UsagePos = GetHeaderPosition(line, "USAGE")
NumCPUPos = GetHeaderPosition(line, "NUMCPU")
keyPos = GetHeaderPosition(line, "LICENSE KEY")
LicensePos = GetHeaderPosition(line, "LICENSE")
ServerPos = GetHeaderPosition(line, "SERVER")
metricPos = GetHeaderPosition(line, "METRIC")
clusterPos = GetHeaderPosition(line, "CLUSTER")
NumCorePos = GetHeaderPosition(line, "NUMCORES")
vmPos = GetHeaderPosition(line, "VMCOUNT")
' Check that the required headers are available
If hostPos = -1 Or productPos = -1 Or (UsagePos = -1 And NumCPUPos = -1) Or (keyPos = -1 And LicensePos = -1) Then
ThisWorkbook.Sheets("File Log").Cells(logRow + 1, 3) = "ERROR: Required column header missing"
ThisWorkbook.Sheets("File Log").Cells(logRow + 1, 3).Interior.ColorIndex = 3
Exit Do
End If
If ServerPos= -1 Then ServerPos = Right(file, Len(file) - InStrRev(file, "\"))
Else
' Check for and correct values with commas and double quotes
If InStr(1, line, Chr(34)) > 0 Then
Set Matches = RegEx.Execute(line)
LineSplit(hostPos) = Replace(Matches.Item(hostPos * 2).Value, Chr(34), "")
LineSplit(productPos) = Replace(Matches.Item(productPos * 2).Value, Chr(34), "")
If UsagePos <> -1 Then LineSplit(UsagePos) = Replace(Matches.Item(UsagePos * 2).Value, Chr(34), "")
If NumCPUPos <> -1 Then LineSplit(NumCPUPos) = Replace(Matches.Item(NumCPUPos * 2).Value, Chr(34), "")
If keyPos <> -1 Then LineSplit(keyPos) = Replace(Matches.Item(keyPos * 2).Value, Chr(34), "")
If LicensePos <> -1 Then LineSplit(LicensePos) = Replace(Matches.Item(LicensePos * 2).Value, Chr(34), "")
If ServerPos<> -1 Then LineSplit(ServerPos) = Replace(Matches.Item(ServerPos* 2).Value, Chr(34), "")
If metricPos <> -1 Then LineSplit(metricPos) = Replace(Matches.Item(metricPos * 2).Value, Chr(34), "")
If clusterPos <> -1 Then LineSplit(clusterPos) = Replace(Matches.Item(clusterPos * 2).Value, Chr(34), "")
If NumCorePos <> -1 Then LineSplit(NumCorePos) = Replace(Matches.Item(NumCorePos * 2).Value, Chr(34), "")
If vmPos <> -1 Then LineSplit(vmPos) = Replace(Matches.Item(vmPos * 2).Value, Chr(34), "")
End If
' Get the deployment details
Host = LineSplit(hostPos)
Product = NormalizeProduct(LineSplit(productPos))
If InStr(1, Product, "VI3") <> 0 Then
VI3Flag = True
End If
If UsagePos <> -1 Then
If InStr(1, LineSplit(UsagePos), " ") <> 0 Then
Usage = Split(LineSplit(UsagePos), " ")
Quantity = Usage(0)
Metric = Usage(1)
Else
If LineSplit(UsagePos) = "" Then
Quantity = 0
Else
Quantity = LineSplit(UsagePos)
End If
End If
Else
Quantity = LineSplit(NumCPUPos)
End If
If keyPos <> -1 Then Key = LineSplit(keyPos)
If LicensePos <> -1 Then License = LineSplit(LicensePos)
If ServerPos<> -1 Then vCenter = LineSplit(ServerPos)
If metricPos <> -1 Then Metric = LineSplit(metricPos)
Select Case Metric
Case "server"
Metric = "Instance"
Case "cpuPackage"
Metric = "CPUs"
Case "vm"
Metric = "VMs"
If vmPos <> -1 Then Quantity = LineSplit(vmPos)
Case ""
Metric = "Check Quantity and Metric"
MetricFlag = True
Case Else
' Do nothing
End Select
If clusterPos <> -1 Then Cluster = LineSplit(clusterPos)
If NumCorePos <> -1 And NumCPUPos <> -1 Then NumCore = LineSplit(NumCorePos) / LineSplit(NumCPUPos)
If keyPos <> -1 Then
AddDeployment Key, Host, Product, Quantity, Key, License, vCenter, Metric, Cluster, NumCore, False
Else
AddDeployment License & Product, Host, Product, Quantity, "", License, vCenter, Metric, Cluster, NumCore, False
End If
End If
End If
Loop
' Update the file log
Add2Log file, "Hosts"
Close #2
End Sub ```
Related
The goal is to provide a folder choosing dialogue to read file names and paste them into the open Word document with the file names being the title (above the picture). This is to ease step by step documentations in Word with a style of "1. Do this", "2. Do that" .... "10. And then that", "11. And then this" (with it being sorted wrong, i.e. 1, 10, 11, 13, 2, 3, 4, 5, 6, 7, 8, 9 without the sorting function).
I can't overcome the type mismatch error, that the following VBA code generates (it seems to be the error of String vs. Array type):
Function:
Function QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer
intBottomTemp = intBottom
intTopTemp = intTop
strPivot = strArray((intBottom + intTop) \ 2)
Do While (intBottomTemp <= intTopTemp)
' < comparison of the values is a descending sort
Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
intBottomTemp = intBottomTemp + 1
Loop
Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom)
intTopTemp = intTopTemp - 1
Loop
If intBottomTemp < intTopTemp Then
strTemp = strArray(intBottomTemp)
strArray(intBottomTemp) = strArray(intTopTemp)
strArray(intTopTemp) = strTemp
End If
If intBottomTemp <= intTopTemp Then
intBottomTemp = intBottomTemp + 1
intTopTemp = intTopTemp - 1
End If
Loop
'the function calls itself until everything is in good order
If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Function
Sub:
Sub PicWithCaption()
Dim xFileDialog As FileDialog
Dim xPath, xFile, xFileNameOnly As String
Dim xFileNameOnlySorted, xFileNameOnlyUnsorted As Variant
Dim xFileNameOnlyUnsortedAsString As String
Dim i, k, l As Integer
l = 1
m = 100
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDialog.Show = -1 Then
xPath = xFileDialog.SelectedItems.Item(i)
If xPath <> "" Then
xFile = Dir(xPath & "\*.*")
For i = 0 To 100
Do While xFile <> ""
xFileNameOnly = Left(xFile, Len(xFile) - 4)
xFileNameOnlyUnsorted(i) = xFileNameOnly
ReDim Preserve xFileNameOnlyUnsorted(0 To i) As Variant
xFileNameOnlyUnsorted(i) = xFileNameOnlyUnsorted(i).Value
Loop
Next i
xFileNameOnlySorted = Module1.QuickSortNaturalNum(xFileNameOnlyUnsorted, l, m)
For xFileNameOnlySorted(k) = 1 To 100
If UCase(Right(xFileNameOnlySorted(k), 3)) = "PNG" Or _
UCase(Right(xFileNameOnlySorted(k), 3)) = "TIF" Or _
UCase(Right(xFileNameOnlySorted(k), 3)) = "JPG" Or _
UCase(Right(xFileNameOnlySorted(k), 3)) = "GIF" Or _
UCase(Right(xFileNameOnlySorted(k), 3)) = "BMP" Then
With Selection
.Text = xFileNameOnlySorted(k)
.MoveDown wdLine
.InlineShapes.AddPicture xPath & "\" & xFile, False, True
.InsertAfter vbCrLf
.MoveDown wdLine
End With
End If
Next xFileNameOnlySorted(k)
xFile = Dir()
End If
End If
End Sub
Here's a slightly different approach:
Sub PicWithCaption()
Dim xPath As String, colImages As Collection, arrFiles, f
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder with files to insert"
.AllowMultiSelect = False
If .Show = -1 Then xPath = .SelectedItems(1) & "\"
End With
If Len(xPath) = 0 Then Exit Sub
Set colImages = ImageFiles(xPath) 'get a Collection of image file names
If colImages.Count > 0 Then 'found some files ?
arrFiles = CollectionToArray(colImages) 'get array from Collection
SortSpecial arrFiles, "SortVal" 'sort files using `Val()`
For Each f In arrFiles 'loop the sorted array
With Selection
.Text = f
.MoveDown wdLine
.InlineShapes.AddPicture xPath & f, False, True
.InsertAfter vbCrLf
.MoveDown wdLine
End With
Next f
Else
MsgBox "No image files found in selected folder"
End If
End Sub
'return a Collection of image files given a folder location
Function ImageFiles(srcFolder As String) As Collection
Dim col As New Collection, f As String
f = Dir(srcFolder & "*.*")
Do While f <> ""
Select Case UCase(Right(f, 3))
Case "PNG", "TIF", "JPG", "GIF", "BMP"
col.Add f
End Select
f = Dir()
Loop
Set ImageFiles = col
End Function
'create and return a string array from a Collection
Function CollectionToArray(col As Collection) As String()
Dim arr() As String, i As Long
ReDim arr(1 To col.Count)
For i = 1 To col.Count
arr(i) = col(i)
Next i
CollectionToArray = arr
End Function
'Sorts an array using some specific translation defined in `func`
Sub SortSpecial(list, func As String)
Dim First As Long, Last As Long, i As Long, j As Long, tmp, arrComp()
First = LBound(list)
Last = UBound(list)
'fill the "compare array...
ReDim arrComp(First To Last)
For i = First To Last
arrComp(i) = Application.Run(func, list(i))
Next i
'now sort by comparing on `arrComp` not `list`
For i = First To Last - 1
For j = i + 1 To Last
If arrComp(i) > arrComp(j) Then
tmp = arrComp(j) 'swap positions in the "comparison" array
arrComp(j) = arrComp(i)
arrComp(i) = tmp
tmp = list(j) '...and in the original array
list(j) = list(i)
list(i) = tmp
End If
Next j
Next i
End Sub
'a function to allow comparing values based on the initial numeric part...
Function SortVal(v)
SortVal = Val(v) ' "1 day" --> 1, "11 days" --> 11 etc
End Function
I've an mathematical expression calculator. For instance: (2+3)*5. The cod works correctly in excel. But in MS Word it doesn't work, becouse there are no Application.Evaluate method in MS Word
I need help with finding an analog of this method in MS Word..
Private Sub TextBox1_Change()
Dim strExpr As String, p As Long, ss As String, qwer As String, i As Integer, a
On Error Resume Next
strExpr = TextBox1.Value
Do
p = InStr(strExpr, ",")
If p = 0 Then Exit Do Else strExpr = Left(strExpr, p - 1) & "." & Mid(strExpr, p + 1)
Loop
If strExpr = Empty Then
Label3.Caption = "": Label1.Caption = ""
Else
Label3.Caption = Application.Evaluate(strExpr)
a = Split(Label3.Caption, ",")
qwer = StrReverse(a(0))
For i = 1 To Len(qwer)
If i Mod 3 = 0 Then ss = ss & Mid(qwer, i, 1) & " " _
Else ss = ss & Mid(qwer, i, 1)
Next
Label1.Caption = StrReverse(ss): ss = ""
If UBound(a) > 0 Then Label1.Caption = Label1.Caption & "," & a(1)
End If
End Sub
But this line of cod doesn't work:
Label3.Caption = Application.Evaluate(strExpr)
I've changed this line of cod:
Label3.Caption = Application.Evaluate(strExpr)
to this line:
Selection=strExpr
Label3.Caption = Selection.Calculate(strExpr)
but, at the same time, the mathematical expression written inside TextBox1 is written / copied into an MS Word document ...
and it returns value with type single...
I have a list of suppliers and I want to check them to see if there are any possible duplicates.
Let's take some example supplier names:
1. The Supplier GmbH
2. Trading Company LLC & Co. KG
3. DHL Express
4. DHL-Express Inc.
5. Supplier GmbH
6. Trading S.a.r.l.
I created two regex functions:
StripNonAlpha that removes all non alpha characters and two letter words and replaces "-" with a space and WordMatch that takes two arguments and returns True if this specific word exists in the company name (I want to check for whole words, not partial, this is why I'm not using InStr).
Taking the vendor names from above, I want to have for example supplier 1 and 5, 3 and 4 marked as possible duplicates but not 2 and 6.
I have around 100K suppliers to check, but the code is running very slow. Any clues how to optimize it?
Function StripNonAlpha(TextToReplace As String) As String
Dim ObjRegex As Object
Set ObjRegex = CreateObject("vbscript.regexp")
With ObjRegex
.Global = True
.Pattern = "[^a-zA-Z\s]+"
StripNonAlpha = .Replace(Replace(TextToReplace, "-", Chr(32)), vbNullString)
.Pattern = "\b.{2}\b"
StripNonAlpha = .Replace(StripNonAlpha, vbNullString)
End With
End Function
Function WordMatch(Source As String, MatchExprValue As String) As Boolean
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.IgnoreCase = True
RE.Pattern = "\b" & MatchExprValue & "\b"
WordMatch = RE.test(Source)
End Function
Sub possible_duplicatev2()
Dim arr1() As String
Dim exclude(1 To 6) As String
Dim arr2() As String
Dim companyname As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim FoundCount As Long
Dim DuplicateCount As Long
Dim rc As Long
Dim scompanyname As String
Dim x As Long
Dim y As Long
exclude(1) = "sarl"
exclude(2) = "gmbh"
exclude(3) = "llc"
exclude(4) = "inc"
exclude(5) = "the"
exclude(6) = "sas"
rc = Range("A" & Rows.Count).End(xlUp).Row
For x = rc To 2 Step -1
If LCase(Range("B" & x).Text) Like "*zzz*" Or LCase(Range("B" & x).Text) Like "*xxx*" Or LCase(Range("B" & x).Text) Like "*yyy*" Then
Range("B" & x).EntireRow.Delete
End If
Next x
rc = Range("A" & Rows.Count).End(xlUp).Row - 1
ReDim arr1(1 To rc, 1 To 2)
For Each companyname In Range("B2", Range("B1").End(xlDown))
scompanyname = StripNonAlpha(LCase(companyname))
arr1(companyname.Row - 1, 1) = scompanyname
Next companyname
For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(exclude)
If WordMatch(arr1(i, 1), exclude(j)) = True Then
Replace arr1(i, 1), exclude(j), ""
End If
Next j
arr2 = Split(arr1(i, 1), " ")
For k = 1 To UBound(arr1, 1)
For l = 0 To UBound(arr2)
If k = i Then
GoTo nextk
ElseIf WordMatch(arr1(k, 1), arr2(l)) = True Then
FoundCount = FoundCount + 1
End If
Next l
If UBound(arr2) = 1 And FoundCount = 1 Then
arr1(k, 2) = "Yes"
DuplicateCount = DuplicateCount + 1
ElseIf UBound(arr2) > 0 And FoundCount > 1 Then
arr1(k, 2) = "Yes"
DuplicateCount = DuplicateCount + 1
Else
arr1(k, 2) = "No"
End If
FoundCount = 0
nextk:
Next k
If DuplicateCount > 0 Then
arr1(i, 2) = "Yes"
Else
arr1(i, 2) = "No"
End If
DuplicateCount = 0
Next i
For y = 1 To UBound(arr1, 1)
Range("D" & y + 1) = arr1(y, 2)
Next y
End Sub
I have a table with a short text field and a function that return a string type. When I compare the field to the returned value of the function a get the following error:
Data type mismatch on criteria expression.
Tables
Query
UPDATE myTable
SET clean = ""
WHERE trimWebAddress(webAddress) in (
SELECT domain FROM genericDomains)
Function
Public Function trimWebAddress(ByVal address As String) As String
Dim cleanAddress As String
If IsNull(address) = False Then
cleanAddress = address
If InStr(1, cleanAddress, "no_domain_available") = 1 Then
cleanAddress = ""
ElseIf InStr(1, cleanAddress, "https://") = 1 Then
cleanAddress = Replace(cleanAddress, "https://", "")
Else
cleanAddress = Replace(cleanAddress, "http://", "")
End If
If InStr(1, cleanAddress, "www.") = 1 Then
cleanAddress = Replace(cleanAddress, "www.", "")
End If
If InStr(1, cleanAddress, "/") > 0 Then
cleanAddress = Left(cleanAddress, InStr(1, cleanAddress, "/") - 1)
End If
Else
cleanAddress = ""
End If
trimWebAddress = cleanAddress
End Function
You may have Null values in your data.
You can modify like this:
Public Function trimWebAddress(ByVal address As Variant) As String
Dim cleanAddress As String
If Nz(address) <> "" Then
cleanAddress = address
If InStr(1, cleanAddress, "no_domain_available") = 1 Then
cleanAddress = ""
ElseIf InStr(1, cleanAddress, "https://") = 1 Then
cleanAddress = Replace(cleanAddress, "https://", "")
Else
cleanAddress = Replace(cleanAddress, "http://", "")
End If
If InStr(1, cleanAddress, "www.") = 1 Then
cleanAddress = Replace(cleanAddress, "www.", "")
End If
If InStr(1, cleanAddress, "/") > 0 Then
cleanAddress = Left(cleanAddress, InStr(1, cleanAddress, "/") - 1)
End If
End If
' Prevent zero-length output.
If cleanAddress = "" Then
cleanAddress = "NotToBeFound"
End If
trimWebAddress = cleanAddress
End Function
Or you may have to update to Null if zero-length string is not allowed:
UPDATE myTable
SET clean = Null
WHERE trimWebAddress(webAddress) in (
SELECT domain FROM genericDomains)
I have cells in vba that contain strings like this:
QUANTITY SUPPLY <= DAYS SUPPLY|30 IN 23 DAYS
I send these strings through two functions that just picks out the two numbers and parses them into the appropriate cells and just scraps the rest. The function that picks out the days number (23) is working fine but the function that picks out the 30 is not. I have been testing it and it seems to be parsing out the 30 as well as the whole string before it when all I want is the 30. In the case of the above string, it is returning "QUANTITY SUPPLY <= DAYS SUPPLY|30" when all I want it to return is the 30. I have looked at the function and cannot find the issue. Any help with this issue would be greatly appreciated!
Public Function extractQLlMax(cellRow, cellColumn) As String
qlm = Cells(cellRow, cellColumn).Value
extractQLlMax = qlm
If extractQLinfoBool = "Yes" And Not InStr(1, qlm, "IN") = 0 Then
If InStr(1, qlm, "QUANTITY SUPPLY") > 0 Then
pipeIndex = InStr(1, qlm, "|")
inIndex = InStr(1, qlm, "IN")
extractQLlMax = Mid(qlm, pipeIndex, inIndex - pipeIndex)
End If
inIndex = InStr(1, qlm, "IN")
extractQLlMax = Mid(qlm, 1, inIndex - 2)
ElseIf extractQLinfoBool = "Yes" And Not InStr(1, qlm, "FILL") = 0 Then
perIndex = InStr(1, qlm, "PER")
extractQLlMax = Mid(qlm, 1, perIndex - 2)
End If
End Function
This is by far the shortest (5 lines) function to extract the numbers!
Function GetNumbers(str As String, Occur As Long) As Long
Dim regex As Object: Set regex = CreateObject("vbscript.RegExp")
regex.Pattern = "(\d+)"
Regex.Global = True
Set matches = regex.Execute(str)
GetNumbers = matches(Occur)
End Function
Parameters:
Str is the string to extract numbers from
Occur is the occurrence of that number (it's 0-based so the first number will have the occurence of 0 not 1 and so on)
Have you considered using the "Split" function in VBA? If it is always pipe delimited, you could try:
Public Function extractQLlMax(cellRow, cellColumn) As String
Dim X as Variant
qlm = Cells(cellRow, cellColumn).Value
extractQLlMax = qlm
If extractQLinfoBool = "Yes" And Not InStr(1, qlm, "IN") = 0 Then
If InStr(1, qlm, "QUANTITY SUPPLY") > 0 Then
x = Split(qlm,"|")
extractQLlMax = X(ubound(x))
ElseIf extractQLinfoBool = "Yes" And Not InStr(1, qlm, "FILL") = 0 Then
perIndex = InStr(1, qlm, "PER")
extractQLlMax = Mid(qlm, 1, perIndex - 2)
End If
End Function
This will extract the first number in a string:
Public Function GetNumber(s As String) As Long
Dim b As Boolean, i As Long, t As String
b = False
t = ""
For i = 1 To Len(s)
If IsNumeric(Mid(s, i, 1)) Then
b = True
t = t & Mid(s, i, 1)
Else
If b Then
GetNumber = CLng(t)
Exit Function
End If
End If
Next i
End Function
You might pass an optional parameter in to distinguish which number you want to pull.
Public Function days_supply(blurb As String, Optional i As Long = 1)
Dim sTMP As String
sTMP = Trim(Split(blurb, "|")(1))
If i = 1 Then
days_supply = CLng(Trim(Left(Replace(sTMP, " ", Space(99)), 99)))
Else
sTMP = Trim(Mid(sTMP, InStr(1, LCase(sTMP), " in ", vbTextCompare) + 4, 9))
days_supply = CLng(Trim(Left(Replace(sTMP, " ", Space(99)), 99)))
End If
End Function
The formula in B1 is,
=days_supply(A1)
The formula in C1 is,
=days_supply(A1,2)