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)
Related
I'm having some trouble getting my macro to use a countif funtion to display the frequency of scores in a given cell. This is part of a larger macro that I am currently working on to generate a report out of a given set of exported data.
When I try to run the code, it returns all zeros in the cells I have specified even though there is data in there that matches my criteria.
Please feel free if you like to critique this code as I am just starting out in programming and wanting to learn as much as possible.
Thanks in advance!
Here is a copy of the code:
Dim i As Integer
Dim ws_raw As Worksheet
Dim ws_rpt As Worksheet
Set ws_raw = Sheets("Raw Data")
Set ws_rpt = Sheets("Report")
If ws_raw.Range("H2") <> "" Then
i = WorksheetFunction.CountIf(Range("S2:CCC2"), "5")
ws_raw.Range("I2").Value = i
i = WorksheetFunction.CountIf(Range("S2:CCC2"), "6")
ws_raw.Range("J2").Value = i
i = WorksheetFunction.CountIf(Range("S2:CCC2"), "7")
ws_raw.Range("K2").Value = i
i = WorksheetFunction.CountIf(Range("S2:CCC2"), "8")
ws_raw.Range("L2").Value = i
Else
End If
Try it as,
i = WorksheetFunction.CountIf(Range("S2:CCC2"), 5)
Text-that-looks-like-a-number is not the same thing as a number; e.g. 5<>"5".
On a related note, explicitly referencing the .Parent worksheet is widely considered 'best practise'. A With ... End With statement not only cleans up your code but speeds it up. I also prefer using the Excel Application object over the of the WorksheetFunction object as any error can be returned to a variant.
Dim i As Variant
Dim ws_raw As Worksheet, ws_rpt As Worksheet
Set ws_raw = Sheets("Raw Data")
Set ws_rpt = Sheets("Report")
With ws_rpt
If ws_raw.Range("H2") <> "" Then
i = Application.CountIf(.Range("S2:CCC2"), 5)
ws_raw.Range("I2").Value = i
i = Application.CountIf(.Range("S2:CCC2"), 6)
ws_raw.Range("J2").Value = i
i = Application.CountIf(.Range("S2:CCC2"), 7)
ws_raw.Range("K2").Value = i
i = Application.CountIf(.Range("S2:CCC2"), 8)
ws_raw.Range("L2").Value = i
Else
End If
End With
You've the numbers you're counting converted to text by putting them in double-quotation marks - try this:
i = WorksheetFunction.CountIf(Range("S2:CCC2"), 5)
ws_raw.Range("I2").Value = i
i = WorksheetFunction.CountIf(Range("S2:CCC2"), 6)
ws_raw.Range("J2").Value = i
i = WorksheetFunction.CountIf(Range("S2:CCC2"), 7)
ws_raw.Range("K2").Value = i
i = WorksheetFunction.CountIf(Range("S2:CCC2"), 8)
ws_raw.Range("L2").Value = i
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.
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
I need to compare two formatted strings. The text in the two of them is the same, only the formatting differs, meaning that some words are bold. The code should tell me if the location of the bold substrings are different e.g. the strings are formatted differently.
So far I tried a char-to-char approach, but it is far too slow.
It's a plain legal current text in MS Word, with cca 10-500 chars per string. Two people independently formatted the strings.
my code so far:
Function collectBold(r As Range) As String
Dim chpos As Integer
Dim ch As Variant
Dim str, strTemp As String
chpos = 1
Do
If r.Characters(chpos).Font.Bold Then
Do
Dim boold As Boolean
strTemp = strTemp + r.Characters(chpos)
chpos = chpos + 1
If (chpos < r.Characters.Count) Then boold = r.Characters(chpos).Font.Bold
Loop While (boold And chpos < r.Characters.Count)
str = str + Trim(strTemp) + "/"
strTemp = ""
Else: chpos = chpos + 1
End If
Loop While (chpos < r.Characters.Count)
collectBold = str
End Function
This code collect all bold substrings (strTemp) and merges them into one string (str), separating them with "/". The function runs for both strings to compare, and then checks if the outputs are the same.
If you only need to see if they are different, this function will do it:
Function areStringsDifferent(range1 As Range, range2 As Range) As Boolean
Dim i As Integer, j As Integer
For i = 1 To range1.Words.Count
'check if words are different formatted
If Not range1.Words(i).Bold = range2.Words(i).Bold Then
areStringsDifferent = True
Exit Function
'words same formatted, but characters may not be
ElseIf range1.Words(i).Bold = wdUndefined Then
For j = 1 To range1.Words(i).Characters.Count
If Not range1.Words(i).Characters(j).Bold = range2.Words(i).Characters(j).Bold Then
areStringsDifferent = True
Exit Function
End If
Next
End If
Next
areStringsDifferent = False
End Function
It first looks if the words are different formatted... If they have the same format but the format is undefinied, it looks into the characters of the word.
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