I am trying to create an array of string variables (not an array of text strings, so to speak), with the goal of passing each variable into the following procedure.
In my actual use case, I have two large blocks of code that are exactly the same for each of two string variables, and I am really just trying to shorten / consolidate my code.
I have pasted an example of the code below.
So I get it...the test will always print "Fail" because it's essentially testing if "strA" = "Apple" and then if "strB" = "Apple", but my intent is for it to test if strA = "Apple" and then if strB = "Apple" (where strA and strB are treated as variables).
Any advice? Is what I am trying to accomplish even possible? Thank you much.
Sub ArrayTest()
'Declare variables
Dim strA As String: strA = "Apple"
Dim strB As String: strB = "Banana"
Dim strArray() As String: strArray = Split("strA,strB", ",")
Dim i As Long
Dim strResult As String
'Test the array
For i = 0 To UBound(strArray)
If strArray(i) = "Apple" Or strArray(i) = "Banana" Then
strResult = "Pass"
Else: strResult = "Fail"
End If
Debug.Print strResult
Next
End Sub
Wrong linking of variables and characters.
Sub ArrayTest()
'Declare variables
Dim strA As String: strA = "Apple"
Dim strB As String: strB = "Banana"
Dim strC As String
strC = strA & "," & strB
Dim strArray() As String: strArray = Split(strC, ",")
Dim i As Long
Dim strResult As String
'Test the array
For i = 0 To UBound(strArray)
If strArray(i) = "Apple" Or strArray(i) = "Banana" Then
strResult = "Pass"
Else: strResult = "Fail"
End If
Debug.Print strResult
Next
End Sub
Related
My Excel raw data looks something like this:
;123456p,Roses and butterflies;;124456h,Violets are blue;
;123456d,Hello world;
Expected output:
Roses and butterflies
Violets are blue
Hello world
Trying to split the text sentences out only, for rows with multiple sentences I would need them in
separate rows, is this at all possible? Below is what I tried.
Private Sub CommandButton1_click()
Dim splitstring As String
Dim myarray() As String
splitstring = Worksheets("raw").Cells(1, 1).Value
myarray = Split(splitstring, ";")
For i = 0 To URound(myarray)
Next
End Sub
Sub raw()
End Sub
With Regular Expressions, you can populate Column B with the desired results ae below
Option Explicit
Private Sub CommandButton1_click()
Dim wSh As Worksheet
Dim rngStr As String, rngStrArr() As String, i As Long
Set wSh = Worksheets("raw")
Dim regEx As Object, mc As Object
Set regEx = CreateObject("vbscript.regexp")
regEx.Global = True
regEx.IgnoreCase = True
rngStr = Join(Application.Transpose(Application.Index(( _
wSh.Range("A1:A" & wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row)), 0, 1)))
regEx.Pattern = ",([^;]+);"
Set mc = regEx.Execute(rngStr)
rngStr = ""
For i = 0 To mc.Count - 1
rngStr = rngStr & mc(i)
Next i
rngStr = Replace(rngStr, ",", "")
rngStrArr = Split(rngStr, ";")
wSh.Range("B1").Resize(UBound(rngStrArr), 1).Value = Application.Transpose(rngStrArr)
End Sub
Try this:
Private sub SplitString()
Dim splitstring As String
Dim myarray() As String
splitstring = Cells(1, 1).Value
myarray = Split(splitstring, ",")
For i = 1 To UBound(myarray)
MsgBox (myarray(i))
Next
End Sub
Here is what I have been given to try and create:
User creates an email a few times per week and has to re-type everything, a request for employee updates, with up to 5 people on it. Easy enough to create in VBA, except that the employees could change each time. So there could be just 1 person, or 2, or 3, etc...and each time it could be a different mix of the employees. They want input boxes that would prompt how many employees for the email, then based on that input, follow-up boxes (if more than 1) that allow the input of the names (1 per box). It then needs to create the email, placing the input box data into the body text. Each email text will be based on the input from the 1st input box, so it can adjust for the number of employees (so there could be up to 5 employees on each email).
How do I assign values to my variables (findstrs and foundcells)so that they will adjust to the inputs of the inputboxes without writing all the IF stmts?
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim X As Long
Dim r As Long
Dim LR, lookrng As Range
Dim findStr As String
Dim nameCol As Range
Dim nameCol1 As Range
Dim nameCol2 As Range
Dim nameCol3 As Range
Dim nameCol4 As Range
Dim foundCell As Variant
Dim foundCell1 As Variant
Dim foundcell2 As Variant
Dim strname As String
Dim strBody As String
Dim sigString As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set oReply = oMail.ReplyAll
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
Set aOutlook = CreateObject("Outlook.Application")
Set oReply = aOutlook.CreateItem(0)
'Input box(es)
findStr = InputBox("Enter Number of Employees")
findstr1 = InputBox("Enter Name of First Employee")
If findStr = "2" Then findstr2 = InputBox("Enter Name of Second Employee")
If findstr1 = "T1" Then foundCell1 = "<B>Test 1 ID#0000</B>"
If findstr1 = "T2" Then foundcell2 = "<B>Test 2 IDO#0001</B>"
If findstr1 = "T3" Then foundcell3 = "<B>Test 3 ID#0002</B>"
If findstr1 = "T4" Then foundCell4 = "<B>Test 4 ID#0003</B>"
If findstr1 = "T5" Then foundCell5 = "<B>Test 5 ID#0004</B>"
If findstr2 = "T1" Then foundCell1 = "<B>Test 1 ID#0000</B>"
If findstr2 = "T2" Then foundcell2 = "<B>Test 2 IDO#0001</B>"
If findstr2 = "T3" Then foundcell3 = "<B>Test 3 ID#0002</B>"
If findstr2 = "T4" Then foundCell4 = "<B>Test 4 ID#0003</B>"
If findstr2 = "T5" Then foundCell5 = "<B>Test 5 ID#0004</B>"
'Greeting based on time of day
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Update.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
If findStr = "1" Then
strBody = "<Font Face=calibri>Can you please update the following: <br><br>" & _
"<B>" & foundCell1 & "</B><br><br>" & _
"Please update this batch. " & _
"I Appreciate your help. Let me know if you need anything.<br><br>" & _
"Thanks <br><br>" & _
subject = "Employee Update"
ElseIf findStr = "2" Then
strBody = "<Font Face=calibri>Can you please add changes for the following: " & _
"<ol><li><B>" & foundCell1 & "</B><br><br><br><br>" & _
"<li><B>" & foundcell2 & "</B><br><br>" & _
subject = "Multiple Employee Requests"
End If
'Sets up the email itself and then displays for review before sending
With oReply
.HTMLBody = "<Font Face=calibri>Hi there,<br><br>" & strBody & signature
.To = "superman#krypton.com"
.CC = "trobbins#shawshank.com "
.subject = "Multiple Employee Updates"
.Importance = 2
.Display
End With
End Sub
You need to break this code down into multiple, smaller and parameterized scopes.
Make a Function that returns the body of the email given a Collection of batch numbers.
Private Function GetEmailBody(ByVal batchNumbers As Collection) As String
Now, the calling code needs to know how many employees there are. Make a function for that.
Private Function GetNumberOfEmployees() As Long
Dim rawInput As Variant
rawInput = InputBox("Number of employees?")
If StrPtr(rawInput) = 0 Then
'user cancelled out of the prompt
GetNumberOfEmployees = -1
Exit Function
Else If IsNumeric(rawInput) Then
GetNumberOfEmployees = CLng(rawInput)
End If
End Function
That'll return -1 if user cancels the prompt, 0 for an invalid input, and the number of employees otherwise.
Dim employeeName As String
Dim nbEmployees As Long
nbEmployees = GetNumberOfEmployees
If nbEmployees = -1 Then
Exit Sub 'bail out
Else If nbEmployees = 0 Then
'reprompt?
Exit Sub 'bail out, cancelled
End If
'fun part here
Dim emailbody As String
emailBody = GetEmailBody(batchNumbers, employeeName)
And now the fun part: you need to add as many items to some batchNumbers collection, as you have nbEmployees. Because you know how many iterations you'll need before you start looping, a For loop will do.
Dim batchNumbers As Collection
Set batchNumbers = New Collection
Dim batchNumber As String
Dim i As Long
For i = 1 To nbEmployees
batchNumber = GetBatchNumber(i)
If batchNumber = vbNullString Then Exit Sub 'bail out:cancelled/invalid
batchNumbers.Add batchNumber
Next
Dim body As String
body = GetEmailBody(batchNumbers)
Where GetBatchNumber(i) is yet another function call, to a function whose role it is to prompt for an employee number and lookup & return the corresponding batch number, returning an empty string if prompt is cancelled or no match is found.
Private Function GetBatchNumber(ByVal index As Long) As String
Dim rawInput As Variant
rawInput = InputBox("Name of employe " & index & ":")
If StrPtr(rawInput) = 0 Then
'cancelled
Exit Function
Else
Dim employeeName as String
employeeName = CStr(rawInput)
GetBatchNumber = GetBatchForEmployee(employeeName)
End If
End Function
If the mappings really actually look like T1 -> <B>Test 1 ID#000</B> then you can probably use this:
Private Function GetBatchForEmployee(ByVal employeeName As String)
Dim digit As Long
digit = CLng(Right$(employeeName, 1))
GetBatchForEmployee = "<B>Test " & digit & " ID#" & Format$(digit - 1, "000") & "</B>"
End Function
If your mappings are actual mappings then you can have a Dictionary lookup in here, or look them up on an Excel worksheet, a CSV or XML data file, a SQL Server database, whatever.
But first, break things down. A procedure that starts like this:
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim X As Long
Dim r As Long
Dim LR, lookrng As Range
Dim findStr As String
Dim nameCol As Range
Dim nameCol1 As Range
Dim nameCol2 As Range
Dim nameCol3 As Range
Dim nameCol4 As Range
Dim foundCell As Variant
Dim foundCell1 As Variant
Dim foundcell2 As Variant
Dim strname As String
Dim strBody As String
Dim sigString As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
...is a procedure that's doing way too many things.
Below is my attempt at adding yes/no options to my objshell.popup, getting a type mismatch error, probably doing something wrong...
got it from this website: http://www.informit.com/articles/article.aspx?p=1170490&seqNum=5
Public Sub ShowTable()
Dim myData
Dim myStr As String
Dim x As Integer
Dim myRange As Range
Dim lastrow As Long
Dim nsecond As Long
Dim ws As Worksheet
Call reviewME
UserForm1.Show
Set ws = Worksheets("New Lookups")
lastrow = ws.Cells(Rows.Count, 262).End(xlUp).Row
Set myRange = ws.Range(ws.Cells(2, 262), ws.Cells(lastrow, 262))
myData = myRange.Value
For x = 1 To UBound(myData, 1)
myStr = myStr & myData(x, 1) & vbTab & vbCrLf
Next x
'myStr = myStr & vbNewLine & "Proceed with change requests?"
inttype = vbYesNo + vbQuestion + vbDefaultButton2
Set objshell = CreateObject("Wscript.Shell")
strtitle = "Review your entries"
nsecond = 1
intresult = objshell.popup(myStr, nsecond, strtitle, inttype)
Select Case intresult
Case vbYes
MsgBox "hi"
Case vbNo
MsgBox "no"
End Select
It's because the signature for the Popup method is actually:
WshShell.Popup(strText, [nSecondsToWait], [strTitle], [intType])
and you are forgetting the nSecondsToWait parameter.
nSecondsToWait may be an optional param (as indicated by the brackets around the param name) but if you aren't going to include it then you need to leave an empty slot for it:
intresult = objshell.popup(myStr, , strtitle, inttype)
The type mismatch error is because the second param should be an integer (nSecondsToWait) but you are giving it a string ("Review your entries").
I am using following codes repeatedly. Is there any better alternative.
Dim strtxt as string
strtxt = Replace(strtxt, "String1", "")
strtxt = Replace(strtxt, "String2", "")
strtxt = Replace(strtxt, "String3", "")
strtxt = Replace(strtxt, "String4", "")
strtxt = Replace(strtxt, "String5", "")
strtxt = Replace(strtxt, "String6", "")
strtxt = Replace(strtxt, "String7", "")
Try this
Dim mLBound As Long
Dim mUBound As Long
Dim mSize As Long
Dim result As String
Dim RepChars As Variant
RepChars = Array("a", "b", "c")
mLBound = LBound(RepChars)
mUBound = UBound(RepChars)
result = Range("A2").Value
For mSize = mLBound To mUBound
result = Replace(result, CStr(RepChars(mSize)), "")
Next
Range("A3").Value = result
Or the Regex could be used. Example based on this answer.
Option Explicit
Sub ReplaceWithRegex()
Dim strPattern As String
Dim strReplace As String
Dim regEx As Variant
Dim strtxt As String
Set regEx = CreateObject("vbscript.regexp")
strtxt = "String1.String2.String3.String4.String5.String6.String7.String77"
strPattern = "(String.)" ' (String\d+) for replacing e.g. 'String77' etc.
strReplace = ""
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = strPattern
End With
If regEx.Test(strtxt) Then
Debug.Print regEx.Replace(strtxt, strReplace)
Else
MsgBox ("Not matched")
End If
End Sub
regexr
One way:
Function RemoveTokens(target As String, ParamArray tokens() As Variant) As String
Dim i As Long
For i = 0 To UBound(tokens)
target = Replace$(target, tokens(i), "")
Next
RemoveTokens = target
End Function
?RemoveTokens("AA BB CC DD EE", "BB")
AA CC DD EE
?RemoveTokens("AA BB CC DD EE", "BB", "EE", "AA")
CC DD
I've got the code below which is extracting a string from brackets and it's ok, but now I've found out that sometimes in my string there can be more brackets with texts behind and I need to extract them too. For instance, a list or table.
e.g
hsus(irt)bla dsd (got)(rifk)
I need then: irt, got, rifk to list, how to do it?
Public Function extract_value(str As String) As String
dim str as string
dim openPos as integer
dim closePos as integer
dim midBit as string
str = "sometinhf(HELLO)sds"
openPos = instr (str, "(")
closePos = instr (str, ")")
midBit = mid (str, openPos+1, closePos - openPos - 1)
End Function
Sub Main()
Dim s$
s = "hsus(irt)bla dsd (got)(rifk)"
Debug.Print extract_value(s)
End Sub
Public Function extract_value$(s$)
Dim returnS$
Dim v
v = Split(s, Chr(40))
For Each Item In v
If InStr(Item, Chr(41)) Then
returnS = returnS & Chr(32) & Split(Item, ")")(0)
End If
Next
extract_value = Trim$(returnS)
End Function
You can use a Regexp to extract the matching strings directly
Sub Main()
Dim strTest as string
strTest = "hsus(irt)bla dsd (got)(rifk)"
MsgBox GrabIt(strTest)
End Sub
Function GrabIt(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\((.*?)\)"
.Global = True
If .test(strIn) Then
Set objRegMC = .Execute(strIn)
For Each objRegM In objRegMC
GrabIt = GrabIt & Chr(32) & objRegM.submatches(0)
Next
End If
End With
End Function