This code should translate all the words from it's dictionary in a cell, but instead, it translates only the first line (it only translates "E" to "And"), it should go through all the words and change all the words in the cell.
Sub traducaobeta2()
Dim translate As Object 'scritping.Dictionary
Set translate = CreateObject("Scripting.Dictionary")
translate("e") = "and"
translate("Telefones") = "Telephones"
translate("Livros") = "Books"
translate("Criado mudo") = "Night stand"
translate("Banqueta") = "Stool"
translate("livros") = "books"
translate("cadernos") = "papers"
translate("travesseiros") = "pillows"
translate("Mesa") = "Table"
translate("Materiais de escritório") = "Office materials"
' 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)
activecell.Value = Ucase$(Left$(activecell.Value, 1)) & Right$(activecell.Value, Len(activecell.Value) - 1)
end sub
When you use Split() like this it puts each word into the array but changes them to lower case. The keys in the dictionary are case sensitive and so you need to use lower case keys instead.
translate("e") = "and"
translate("telefones") = "Telephones"
translate("livros") = "Books"
translate("criado mudo") = "Night stand"
translate("banqueta") = "Stool"
translate("livros") = "books"
translate("cadernos") = "papers"
translate("travesseiros") = "pillows"
translate("mesa") = "Table"
translate("materiais de escritório") = "Office materials"
' the list goes on...
on a side note, that last one ("materiais de escritório") will never work because it has spaces in so your array will have materiais, de and escritório in separate indexes and will never match the dictionary key.
In addition to Macro Man's excellent comments, another approach is to completely ignore the LCase, UCase issue. Do not attempt to change or fix cases at all. Instead just beef-up the translate object like:
translate("livros") = "books"
translate("Livros") = "Books"
If the source text has proper capitalization, the translate will work and if the source text is all lower case, the translate should work.
Related
For example "director of medicine" and I want it as "Director of Medicine not "Director Of Medicine" . I do not want letter "of" to be capitalise. Please help
The following VBA code would be a good start.
Option Base 1
Option Explicit
Function ProperIsh(inputString As String) As String
Dim result As String
Dim currWord As String
Dim idx As Integer
Dim wordPos As Integer
' List of words to revert to lower-case '
Dim lowerWords As Variant
lowerWords = Array("Of", "And", "It", "For", "Am", "The")
' Get proper-cased string with spaces on either end '
result = " " & WorksheetFunction.Proper(inputString) & " "
' Process each word to revert to lower-case '
For idx = 1 To UBound(lowerWords)
' Revert every one of that word with spaces on either side '
currWord = " " & lowerWords(idx) & " "
wordPos = InStr(result, currWord)
While wordPos > 0
result = Left(result, wordPos - 1) & LCase(currWord) & Mid(result, wordPos + Len(currWord))
wordPos = InStr(result, currWord)
Wend
Next
' Get rid of the spaces at the end '
ProperIsh = Mid(result, 2, Len(result) - 2)
End Function
And some test code for it:
Sub test()
MsgBox (ProperIsh("HELLO I AM THE LAW and i am the lower case law of everything"))
End Sub
What it does is to proper-case every word (upper-case first letter, everything else lower-case) then systematically revert any of the special words back to all lower-case.
It presupposes that space is the only separator but could be made more adaptable if that's the case.
The test code generates a message box with the expected output:
Hello I am the Law and I am the Lower Case Law of Everything
In order to use it in your expression, treat it as any other user defined function, such as with:
=ProperIsh(A1)
You can see it in operation with the following "screenshot" where column B uses the formula shown above:
A B
1 director of medicine Director of Medicine
2 I am the law I am the Law
3 Let slip the dogs of war Let Slip the Dogs of War
I used Rules for Capitalization in Titles of Articles as a reference to create a capitalization exceptions list.
Function TitleCase uses WorksheetFunction.ProperCase to preproccess the text. For this reason, I put in an exception for contractions because WorksheetFunction.ProperCase improperly capitalizes them.
The first word in each sentence and the first word after a double quotation mark will remain capitalized. Punctuation marks are also handled properly.
Function TitleCase(text As String) As String
Dim doc
Dim sentence, word, w
Dim i As Long, j As Integer
Dim arrLowerCaseWords
arrLowerCaseWords = Array("a", "an", "and", "as", "at", "but", "by", "for", "in", "of", "on", "or", "the", "to", "up", "nor", "it", "am", "is")
text = WorksheetFunction.Proper(text)
Set doc = CreateObject("Word.Document")
doc.Range.text = text
For Each sentence In doc.Sentences
For i = 2 To sentence.Words.Count
If sentence.Words.Item(i - 1) <> """" Then
Set w = sentence.Words.Item(i)
For Each word In arrLowerCaseWords
If LCase(Trim(w)) = word Then
w.text = LCase(w.text)
End If
j = InStr(w.text, "'")
If j Then w.text = Left(w.text, j) & LCase(Right(w.text, Len(w.text) - j))
Next
End If
Next
Next
TitleCase = doc.Range.text
doc.Close False
Set doc = Nothing
End Function
This code is translating all the words in a cell, but only the first should be forced to Proper case, the other words should keep the case written by the user, but instead it is forcing the first word to proper case and all the other words in the cell to lower case. All the other words should mantain its original case.
Sub TraAdd()
Dim translate As Object 'scritping.Dictionary
Set translate = CreateObject("Scripting.Dictionary")
translate("modens") = "modems"
translate("Modens") = "Modems"
translate("modens,") = "modems,"
translate("Modens,") = "Modems,"
translate("Fruteira,") = "Fruit bowl,"
translate("fruteira,") = "fruit bowl,"
translate("Fruteira") = "Fruit bowl"
translate("fruteira") = "fruit bowl"
translate("muletas") = "crutches"
translate("Muletas") = "Crutches"
translate("muletas,") = "crutches,"
translate("Muletas,") = "Crutches,"
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)
activecell.Value = Ucase$(Left$(activecell.Value, 1)) & Right$(activecell.Value, Len(activecell.Value) - 1)
End Sub
Any ideas?
You have made all of your content lowercase when you split it into an array.
Remove LCase when you split the cell content to Words and it should work as you intend:
Words = Split(activecell.Value)
Let's assume that we have one module with only one Sub in it, and there are no comments. How to identify all variable names ? Is it possible to identify names of variables which are not defined using Dim ? I would like to identify them and replace each with some random name to obfuscate my code (O0011011010100101 for example), replace part is much easier.
List of characters which could be use in names of macros, functions and variables :
ABCDEFGHIJKLMNOPQRSTUVWXYZdefghijklmnopqrstuvwxyzg€‚„…†‡‰Š‹ŚŤŽŹ‘’“”•–—™š›śťžź ˇ˘Ł¤Ą¦§¨©Ş«¬®Ż°±˛ł´µ¶·¸ąş»Ľ˝ľżŔÁÂĂÄĹĆÇČÉĘËĚÍÎĎĐŃŇÓÔŐÖ×ŘŮÚŰÜÝŢßŕáâăäĺćçčéęëěíîďđńňóôőö÷řůúűüýţ˙ÉĘËĚÍÎĎĐŃŇÓÔŐÖ×ŘŮÚŰÜÝŢßŕáâăäĺćçčéęëěíîďđńňóôőö÷řůúűüýţ˙
Below are my function I've wrote recenlty :
Function randomName(n as integer) as string
y="O"
For i = 2 To n:
If Rnd() > 0.5 Then
y = y & "0"
Else
y = y & "1"
End If
Next i
randomName=y
End Function
In goal to replace given strings in another string which represent the code of module I use below sub :
Sub substituteNames()
'count lines in "Module1" which is part of current workbook
linesCount = ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule.CountOfLines
'read code from module
code = ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule.Lines(StartLine:=1, Count:=linesCount)
inputStr = Array("name1", "name2", "name2") 'some hardwritten array with string to replace
namesLength = 20 'length of new variables names
For i = LBound(inputStr) To UBound(inputStr)
outputString = randomName(namesLength-1)
code = Replace(code, inputStr(i), outputString)
Next i
Debug.Print code 'view code
End Sub
then we simply substitute old code with new one, but how to identify strings with names of variables ?
Edition
Using **Option Explicit ** decrease safety of my simple method of obfuscation, because to reverse changes you only have to follow Dim statements and replace ugly names with something normal. Except that to make such substitution harder, I think it's good idea to break the line in the middle of variable name :
O0O000O0OO0O0000 _
0O00000O0OO0
the simple method is also replacing some strings with chains based on chr functions chr(104)&chr(101)&chr(108)&chr(108)&chr(111) :
Sub stringIntoChrChain()
strInput = "hello"
strOutput = ""
For i = 1 To Len(strInput)
strOutput = strOutput & "chr(" & Asc(Mid(strInput, i, 1)) & ")&"
Next i
Debug.Print Mid(strOutput, 1, Len(strOutput) - 1)
End Sub
comments like below could make impression on user and make him think that he does not poses right tool to deal with macro etc.:
'(k=Äó¬)w}ż^¦ů‡ÜOyúm=ěËnóÚŽb W™ÄQó’ (—*-ĹTIäb
'R“ąNPÔKZMţ†üÍQ‡
'y6ű˛Š˛ŁŽ¬=iýQ|˛^˙ ‡ńb ¬ĂÇr'ń‡e˘źäžŇ/âéç;1qýěĂj$&E!V?¶ßšÍ´cĆ$Âű׺Ůî’ﲦŔ?TáÄu[nG¦•¸î»éüĽ˙xVPĚ.|
'ÖĚ/łó®Üă9Ę]ż/ĹÍT¶Mµę¶mÍ
'q[—qëýY~Pc©=jÍ8˘‡,Ú+ń8ŐűŻEüńWü1ďëDZ†ć}ęńwŠbŢ,>ó’Űçµ™Š_…qÝăt±+‡ĽČgřÍ!·eŠP âńđ:ŶOážű?őë®ÁšńýĎáËTbž}|Ö…ăË[®™
You can use a regular expression to find variable assignments by looking for the equals sign. You'll need to add a reference to the Microsoft VBScript Regular Expressions 5.5 and Microsoft Visual Basic for Applications Extensibility 5.3 libraries as I've used early binding.
Please be sure to back up your work and test this before using it. I could have gotten the regex wrong.
UPDATE:
I've refined the regular expressions so that it no longer catches datatypes of strongly typed constants (Const ImAConstant As String = "Oh Noes!" previously returned String). I've also added another regex to return those constants as well. The last version of the regex also mistakenly caught things like .Global = true. That was corrected. The code below should return all variable and constant names for a given code module. The regular expressions still aren't perfect, as you'll note that I was unable to stop false positives on double quotes. Also, my array handling could be done better.
Sub printVars()
Dim linesCount As Long
Dim code As String
Dim vbPrj As VBIDE.VBProject
Dim codeMod As VBIDE.CodeModule
Dim regex As VBScript_RegExp_55.RegExp
Dim m As VBScript_RegExp_55.match
Dim matches As VBScript_RegExp_55.MatchCollection
Dim i As Long
Dim j As Long
Dim isInDatatypes As Boolean
Dim isInVariables As Boolean
Dim datatypes() As String
Dim variables() As String
Set vbPrj = VBE.ActiveVBProject
Set codeMod = vbPrj.VBComponents("Module1").CodeModule
code = codeMod.Lines(1, codeMod.CountOfLines)
Set regex = New RegExp
With regex
.Global = True ' match all instances
.IgnoreCase = True
.MultiLine = True ' "code" var contains multiple lines
.Pattern = "(\sAs\s)([\w]*)(?=\s)" ' get list of datatypes we've used
' match any whole word after the word " As "
Set matches = .Execute(code)
End With
ReDim datatypes(matches.count - 1)
For i = 0 To matches.count - 1
datatypes(i) = matches(i).SubMatches(1) ' return second submatch so we don't get the word " As " in our array
Next i
With regex
.Pattern = "(\s)([^\.\s][\w]*)(?=\s\=)" ' list of variables
' begins with a space; next character is not a period (handles "with" assignments) or space; any alphanumeric character; repeat until... space
Set matches = .Execute(code)
End With
ReDim variables(matches.count - 1)
For i = 0 To matches.count - 1
isInDatatypes = False
isInVariables = False
' check to see if current match is a datatype
For j = LBound(datatypes) To UBound(datatypes)
If matches(i).SubMatches(1) = datatypes(j) Then
isInDatatypes = True
Exit For
End If
'Debug.Print matches(i).SubMatches(1)
Next j
' check to see if we already have this variable
For j = LBound(variables) To i
If matches(i).SubMatches(1) = variables(j) Then
isInVariables = True
Exit For
End If
Next j
' add to variables array
If Not isInDatatypes And Not isInVariables Then
variables(i) = matches(i).SubMatches(1)
End If
Next i
With regex
.Pattern = "(\sConst\s)(.*)(?=\sAs\s)" 'strongly typed constants
' match anything between the words " Const " and " As "
Set matches = .Execute(code)
End With
For i = 0 To matches.count - 1
'add one slot to end of array
j = UBound(variables) + 1
ReDim Preserve variables(j)
variables(j) = matches(i).SubMatches(1) ' again, return the second submatch
Next i
' print variables to immediate window
For i = LBound(variables) To UBound(variables)
If variables(i) <> "" And variables(i) <> Chr(34) Then ' for the life of me I just can't get the regex to not match doublequotes
Debug.Print variables(i)
End If
Next i
End Sub
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
I am creating a for each loop to take the words from a string and place them each into a text box. The program allows for up to "9" variables What I am trying to attempt is.
Foreach word in Words
i = i +1
Varible & i = word
txtCritical1.Text = variable & i
any ideas on a way to make this work?
Have a look through the MSDN article on For Each. It includes a sample using strings.
https://msdn.microsoft.com/en-us/library/5ebk1751.aspx
So i went with a simple if statement this does the trick. Each text box is filled in.
Dim details As String = EditEvent.EditDbTable.Rows(0).Item(13).ToString()
Dim words As String() = details.Split(New Char() {"«"})
Dim word As String
For Each word In words
i = i + 1
v = word
If i = 1 Then
txtCritical1.Text = v
ElseIf i = 2 Then
txtCritical2.Text = v
ElseIf ....
ElseIf i = 9 then
txtCritical2.text = v
Else
....
End If
Next