My translation code is not working as I wanted... It should do the Propercase only in the first word of the cell, but it is doing the propercase in all of the words in the cell.
Any ideas on how to make it translate and only use propercase on the first word in the activecell?
Here is the code:
Sub traducaobeta2()
Dim translate As Object 'scritping.Dictionary
Set translate = CreateObject("Scripting.Dictionary")
translate("cadeira") = "chair"
translate("cadeira,") = "chair"
translate("cadeiras") = "chairs"
translate("criado mudo") = "night stand"
translate("criado-mudo") = "night stand"
translate("mesa") = "table"
translate("mesas") = "tables"
translate("e") = "and"
' the list goes on...
Dim Words As Variant
Dim I As Integer
Words = Split(LCase(activecell.Value))
For I = LBound(Words) To UBound(Words)
If translate(Words(I)) <> "" Then Words(I) = translate(Words(I))
Next
activecell.Value = Join(Words)
For Each x In activecell
x.Value = Application.Proper(x.Value)
Next
activecell.Offset(0, 1).Select
End Sub
Just make the first letter a captial:
ActiveCell.value = UCase$(Left$(ActiveCell.value, 1)) & Right$(ActiveCell.value, Len(ActiveCell.value) - 1)
Could also use a With block to save typing:
With ActiveCell
.value = UCase$(Left$(.value, 1)) & Right$(.value, Len(.value) - 1)
End With
Related
I have multiple rows with some words separeted by semicolons(;), and need to count how many times a certain word appears in Column A cell strings of Sheet1.
Using two rows for example:
Column "A"
Banana; Apple; Orange
Banana; Banana; Apple
I came up with this code for the counting of the specific word I want to count:
Sub count()
'The count will be registered in "B6"
strcount = "Banana"
For i = 2 to 30
If InStr(Sheets("Sheet1").Cells(i, "A").Text, strcount) <> 0 Then
Cells(6, "B").Value = Cells(6, "B").Value + 1
End If
Next i
End Sub
The problem with this code is that it doesn't recognize the 2 appearences of "Banana" in the second row returning me a count of 2 instead of 3:
Results for each fruit:
Banana: 2
Apple: 2
Orange: 1
I see that the problem is InStr only recognizes if the string is there, but how can I overcome this?
Solution:
Both basodre's and Алексей's answers worked.
For basodre's code I had to change only the delimiter from ";" to "; " (with a space after the semicolon) to match my string.
aFoods = Split(rIterator.Value, "; ")
Алексей's answer works perfectly too, but by the time of this edit is limited for Excel 2019 or above, given it uses the "TEXTJOIN" function and I couldn't come up with a replacement for that.
Here's an example that I think does what you need. Please review, modify to your range, and let us know if it works.
Sub CountWords()
Dim rng As Range
Dim aFoods As Variant
Dim rIterator As Range
Dim counter As Long
Const theFood As String = "Banana"
Set rng = Range("A1:A3")
counter = 0
For Each rIterator In rng
aFoods = Split(rIterator.Value, ";")
For i = LBound(aFoods) To UBound(aFoods)
If aFoods(i) = theFood Then
counter = counter + 1
End If
Next i
Next rIterator
Debug.Print counter
End Sub
Solution with RegExp:
Option Explicit
Sub test1()
Dim re As Object, result As Object, text As String, fruit As Variant
Set re = CreateObject("vbscript.regexp")
re.Global = True
text = WorksheetFunction.TextJoin(";", True, Columns("A"))
'In Excel < 2019 you can use: text = Join(WorksheetFunction.Transpose(Intersect(Columns("A"), ActiveSheet.UsedRange)), ";")
For Each fruit In Array("Banana", "Apple", "Orange")
re.Pattern = "\b" & fruit & "\b"
Set result = re.Execute(text)
Debug.Print "Amount of [" & fruit & "] = " & result.Count
Next
End Sub
Output:
Amount of [Banana] = 3
Amount of [Apple] = 2
Amount of [Orange] = 1
Using regular expression
Sub FindEntries()
Dim mc, rw
Const word$ = "Banana"
With CreateObject("VBScript.RegExp")
.IgnoreCase = True: .Global = True: .Pattern = "(^|;\s+)" & word & "(?=;|$)"
For rw = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Set mc = .Execute(Cells(rw, "A")): [B6] = [B6] + mc.Count
Next
End With
End Sub
As in my title, I'm trying to filter out specific strings from a VBA array, based on an other array.
My code looks something like this :
For Each item In exclusions_list
updated_list = Filter(updated_list, item, False, vbTextCompare)
Next item
My issue is that I only want to exclude exact matches and I can't seem to find a way to do so.
If I have "how" in exclusions_list, I'd like to exclude "how" from updated_list but not "however".
My apologies if this has been asked before. I couldn't find a clear answer and I am not very familiar with VBA.
Thanks !
The Filter method only looks for substrings. It does not have a way of recognizing whole words.
One way to do this is by using Regular Expressions which include a token to recognize word boundaries. This will only work if the substrings you are considering do not include non-Word characters. Word characters are those in the set of [A-Za-z0-9_] (with some exceptions for non-English languages).
For example:
Option Explicit
Sub foo()
Dim arr
Dim arrRes
Dim V
Const sfilter As String = "gi"
Dim col As Collection
arr = Array("Filter", "by", "bynomore", "gi", "gif")
Dim re As Object, MC As Object, I As Long
Set col = New Collection
Set re = CreateObject("vbscript.regexp")
With re
.ignorecase = True
.Pattern = "\b" & sfilter & "\b"
For I = 0 To UBound(arr)
If .test(arr(I)) = False Then _
col.Add arr(I)
Next I
End With
ReDim arrRes(0 To col.Count - 1)
For I = 1 To col.Count
arrRes(I - 1) = col(I)
Next I
End Sub
The resulting array arrRes will contain gif but not gi
Approach via a very simple Replace function
In addition to the valid solutions above and just to demonstrate another approach using a simple Replace function. This solution doesn't pretend to be the most efficient way to execute exclusions.
Example code
Sub Howdy()
' Purpose: exclude exactly matching array items (not case sensitive)
Dim exclusions_list, updated_list, item
exclusions_list = Array("How", "much")
' assign test list (with successive repetitions)
updated_list = Split("Bla bla,How,how,Howdy,However,How,much,much,much,Much,Much,How much,something else", ",")
' Debug.Print UBound(updated_list) + 1 & " items in original list: """ & Join(updated_list, "|") & """"
' execute exclusions
For Each item In exclusions_list
updated_list = modifyArr(updated_list, item) ' call helper function modifyArr()
' Debug.Print UBound(updated_list) + 1 & " items excluding """ & item & """:" & vbTab & """" & _
Join(updated_list, "|") & """"
Next item
End Sub
Note
Not outcommenting the Debug.Print Statements you'd get the following results in the VBE immediate window:
13 items in original list: "Bla bla|How|how|Howdy|However|How|much|much|much|Much|Much|How much|something else"
10 items excluding "How": "Bla bla|Howdy|However|much|much|much|Much|Much|How much|something else"
5 items excluding "much": "Bla bla|Howdy|However|How much|something else"
Helper function modifyArr()
Please note that it's necessary to provide for successive repetitions of strings to be excluded, as a single Replace statement wouldn't exceute every wanted replacement in subsequent string parts.
Function modifyArr(ByVal arr, ByVal item) As Variant
Const C = ",": Dim temp$, sLen$
temp = Replace(C & Join(arr, C) & C, C & item & C, Replace:=C, Compare:=vbTextCompare)
Do While True ' needed to get successive repetitions !
sLen = Len(temp)
temp = Replace(temp, C & item & C, Replace:=C, Compare:=vbTextCompare)
If sLen = Len(temp) Then Exit Do
Loop
' return
modifyArr = Split(Mid$(temp, 2, Len(temp) - 2), C)
End Function
Add a reference to RegEx:
Option Explicit
Sub Filter()
Dim words() As String
words = Split("how,however,test3,test4,,,howevermore,how,whatsohowever,test1,test2", ",")
Dim regex As New RegExp
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "^how$" ' ^ means must start with and $ means must end with
End With
Dim i As Integer
For i = 0 To UBound(words)
If regex.Test(words(i)) Then
' Debug.Print words(i) + " is an exact match!"
words(i) = vbNullString ' Just clear out item, skip later.
Else
' Debug.Print words(i) + " is NOT a match!"
End If
Next i
For i = 0 To UBound(words)
If (StrPtr(words(i)) <> 0) Then ' We can use this to explicitly catch vbNullString, because "" has a pointer.
Debug.Print words(i)
End If
Next i
End Sub
Initially, I'm not clear why people are getting into RegExp here. RegExp is for complex pattern matching, not an exact match. For more on that point, see another answer here.
Basic Loop
The simplest way to do this is to loop through the array and test each value:
Sub ShowFilterOutExact()
startingArray = Array("Filter", "by", "bynomore", "gi", "gif")
filteredArray = FilterOutExact("gif", startingArray)
End Sub
Function FilterOutExact(exactValue, sourceArray)
'Start with a returnArray the same size as the sourceArray
ReDim returnArray(UBound(sourceArray))
For i = 0 To UBound(sourceArray)
If sourceArray(i) <> exactValue Then
returnArray(matchIndex) = sourceArray(i)
matchIndex = matchIndex + 1
End If
Next
'Now trim the returnArray down to size
ReDim Preserve returnArray(matchIndex - 1)
FilterOutExact = returnArray
End Function
For alternatives to the equal operator (or <> for "does not equal"), this answer has more details.
Replace and Filter
You can also do a workaround with the built in Filter() function to get an exact match.
Function FilterExactMatch(SourceArray, Match, Optional DumpValue = "#/#/#", Optional Include = True)
'Make sure the DumpValue is not found in the sourceArray in any element
For i = LBound(SourceArray) To UBound(SourceArray)
ExactMatch = SourceArray(i) = Match
If ExactMatch Xor Include Then SourceArray(i) = DumpValue
Next
FilterExactMatch = Filter(SourceArray, DumpValue, False)
End Function
Filter out multiple values at once
Finally, it turns out the Application.Match function can check an array of values against an array of values to see if any match. This can be used to filter out multiple values at once (or just one) on an exact basis.
Function FilterOutMultiple(unwantedValuesArray, sourceArray)
If LBound(sourceArray) <> 0 Then
MsgBox "sourceArray argument must be zero-based for this to work as written"
Exit Function
End If
matchArray = Application.Match(sourceArray, unwantedValuesArray, 0)
matchCount = Application.Count(matchArray) 'Count non-error values
ReDim returnArray(UBound(sourceArray) - matchCount)
j = -1
For i = 0 To UBound(sourceArray)
If IsError(matchArray(i + 1)) Then 'Keep the error indexes
j = j + 1
returnArray(j) = sourceArray(i)
End If
Next
FilterOutMultiple = returnArray
End Function
I need a bit of help with a small project. I just started VBA and I think I could use learning to optimise my code.
Cell A2, contains a text with many email address separated by ",". I managed to extract all the email addresses but I think I made too much use of cells, and I was wondering if you can help me reduce that and use the variables defined instead.
Screenshot of the working code
Sub fpor()
Dim Text As String
Dim full As Integer
Dim i As Integer
Dim e As Integer
Dim part As String
Dim part_len As Integer
Dim part_a As Integer
Dim Text_2 As String
x = 5
ActiveCell = Range("A2")
Text = Range("A2")
full = Len(Text)
'full = InStrRev(Text, ",")
For i = 1 To full
Cells((x + i), 1).Value = Text
part = InStr(Text, ",")
Cells((x + i), 2).Value = part
Cells((x + i), 3) = Left(Text, part)
Cells((x + i), 4) = full - part
Text = Right(Cells((x + i), 1), Cells((x + i), 4))
If part = 0 Then
full = 0
Cells((x + i), 3) = Text
Exit For
Else:
full = Len(Text)
End If
Next i
MsgBox (full)
MsgBox (part)
End Sub `
How do you think I can better optimise the For Loop?
Thank you all for your answers you awesome people : )
you can greatly simplify your code with the use of Split() Function as follows:
Option Explicit
Sub fpor()
Dim emailsArr As Variant
With Worksheets("emails") '<--change "emails" with your actual sheet name
emailsArr = Split(.Range("a2"), ",") '<--| split all emails names delimited by a ',' into an array
.Range("A6").Resize(UBound(emailsArr)).value = Application.Transpose(emailsArr) '<--| write array content from cell A6 downwards
End With
End Sub
I have the following search code:
Private Sub Search_Click()
Dim Name As String
Dim f As Range
Dim r As Long
Dim ws As Worksheet
Dim s As Integer
Dim FirstAddress As String
Name = surname.Value
With ws
Set f = Range("A:A").Find(what:=Name, LookIn:=xlValues)
If Not f Is Nothing Then
With Me
firstname.Value = f.Offset(0, 1).Value
tod.Value = f.Offset(0, 2).Value
program.Value = f.Offset(0, 3).Value
email.Value = f.Offset(0, 4).Text
officenumber.Value = f.Offset(0, 6).Text
cellnumber.Value = f.Offset(0, 7).Text
if f.offset(0,5).value = "PACT" then PACT.value = True
I want to modify the if f.offset(0,5).value: If I have one single value in a cell then it's easy to pick that one cell, link it to the checkbox and have the checkbox checkmarked. The problem is I have multiple values in the cell.
The values in the column 6 (f.offset(0,5).values) have the names as the checkboxes eg., checkboxes.name & " " so... PACT OTTAWA VANCOUVER MONTREAL TORONTO
This is done through an add command.
So the column 6 can display PACT OTTAWA VANCOUVER or PACT TORONTO or TORONTO depending on which checkboxes are clicked to add in userform.
If I can read and link to the name of the checkboxes and checkmark the ones that are in column 6 then that would work.
if f.offset(0,5).value = "PACT" then PACT.value = True
If I do it this way, then I'll have way too many combinations that I have to figure it out using if statements. Is there a way to "read" column 6, match it to the names of checkbox and checkmark the checkboxes in the userform when I click the search button?
EDIT:
Private Sub Search_Click()
Dim Name As String
Dim f As Range
Dim r As Long
Dim ws As Worksheet
Dim s As Integer
Dim FirstAddress As String
Dim str() As String
Name = surname.Value
With ws
Set f = Range("A:A").Find(what:=Name, LookIn:=xlValues)
If Not f Is Nothing Then
With Me
firstname.Value = f.Offset(0, 1).Value
tod.Value = f.Offset(0, 2).Value
program.Value = f.Offset(0, 3).Value
email.Value = f.Offset(0, 4).Text
officenumber.Value = f.Offset(0, 6).Text
cellnumber.Value = f.Offset(0, 7).Text
str() = Split(inputstr, " ")
For i = 0 To UBound(str)
Select Case UCase(Trim(str(i)))
Case "PACT": PACT.Value = True
Case "PrinceRupert": PrinceRupert.Value = True
Case "Montreal": Montreal.Value = True
Case "TET": TET.Value = True
Case "WPM": WPM.Value = True
Case "TC": TC.Value = True
Case "US": US.Value = True
Case "Other": Other.Value = True
End Select
Next i
I've added the following code but nothing happens.
I've searched on msdn but I don't quite understand the str() = split(inputstr, " ") and for I = 0 Ubound (str). I'm assuming the trim function is if after trimming the values of column 6 and case is "PACT" then PACT.value = True?
EDIT2:
It seems the code doesn't catch the words other than PACT and I'm assuming it picks up PACT because it's the first one. I've tried manually inputting the column 6 values and see if any names get picked up but it doesn't. Is there a way to fix this?
Perhaps it's because when I trim the data in column 6, it's seen as PACTPrinceRupertTETWPMTCUSOther. Is that why it won't pick it up?
Just as Siddharth said, Using split() and looping through the resulting array...
Dim str() As String
str() = Split(inputstr, " ")
For i = 0 To UBound(str)
Select Case ucase(trim(str(i)))
Case "PACT": pact.Value = True
case ....:
End Select
Next i
I have a bunch of strings comprising of characters "A","B"..."Z" (and no others). A typical string looks like ABZYC. The strings are given to me in pairs like ABC,ABDC. The strings are comparable if one string is contained in the other (i.e either one of the two strings contain all the alphabets of the other). The order in which the string appears don't matter.
Is there any direct function in excel vba which does this sort of comparison?
Examples:
ACBD,AC - Match
ACBD,CA - Match
ACBD,ADB - Match
AC,ABCD - Match
ABC, ABD - No Match
Add the following function in a module in your workbook:
Function allIn(str1, str2)
' check whether all elements of str1 occur in str2
' and vice versa
Dim l1, l2, ii As Integer
Dim isfound As Boolean
isfound = True
l1 = Len(str1)
l2 = Len(str2)
If l1 < l2 Then
' look for all the elements of str1 in str2
For ii = 1 To l1
If InStr(1, str2, Mid(str1, ii, 1), vbTextCompare) <= 0 Then
isfound = False
Exit For
End If
Next ii
Else
' look for all the elements of str2 in str1
For ii = 1 To l2
If InStr(1, str1, Mid(str2, ii, 1), vbTextCompare) <= 0 Then
isfound = False
Exit For
End If
Next ii
End If
allIn = isfound
End Function
Now you can call this from another place in your code, using result = inStr("ABD", "BAD") - or from the spreadsheet itself. On the spreadsheet you would type =allIn(A3, B6) to compare strings in cells A3 and B6.
Here is what happens when I did that (I entered =allIn(A1, B1) in cell C1, then dragged the formula to the next four rows):
I believe that solves your problem.
EDIT: I just noticed #Philip's comment to your question - I appear to have implemented his suggestion although I had not seen it when I started to compose it... But here's a tip of the hat all the same!
INSTR will find a substring in a string:
Typical_String = "ABZYC"
if instr(Typical_String,"ABC") > 0 then
If you want a Formula solution, a user called Schielrn on the Mr Excel forum site came up with this sublime masterpiece (using ARRAY FORMULAS)
Or, if you want a VBA, try this...
Sub compare()
Dim iIndx As Integer
Dim str1 As String
Dim str2 As String
Dim sLetter As String
Dim bFound As Boolean
Range("A1").Select
bFound = False
Do
str1 = VBA.Trim(ActiveCell.Text)
str2 = VBA.Trim(ActiveCell.Offset(0, 1).Text)
For iIndx = 1 To Len(str1)
If VBA.InStr(str2, VBA.Mid(str1, iIndx, 1)) <> "" Then
' found it
bFound = True
Else
bFound = False
exit for
End If
Next
If bFound = False Then
' check the other way!
For iIndx = 1 To Len(str2)
If VBA.InStr(str1, VBA.Mid(str2, iIndx, 1)) <> "" Then
' found it
bFound = True
Else
bFound = False
exit for
End If
Next
End If
If bFound = True Then ActiveCell.Offset(0, 2).Value = "MATCHED!"
ActiveCell.Offset(1, 0).Select
Loop While Not ActiveCell.Offset(1, 0).Text = ""
End Sub
I missread the post!
Use function EXACT
Compares two text strings and returns TRUE if they are exactly the
same, FALSE otherwise. EXACT is case-sensitive but ignores formatting
differences.
I usually add the function UPPER ie:
A1 = Some Place
B1 = some place
with
=EXACT(UPPER(A1),UPPER(B1)) = EXACT(SOME PLACE, SOME PLACE) = TRUE
Without UPPER
=EXACT(A1,B1) = EXACT(Some Place, some place) = FALSE