In MS-Word I have text like this: hif.imp. ינעימשת od שמע
When I double click on the on the hebrew word the range is selected with the space after the word. I wanted to create macro, that will reduce the white space characters.
Dim r1 As Range
Dim str1 As String
Set r1 = Selection.Range
r1.SetRange Start:=0, End:=Len(Trim(r1.Text))
However when I run this, nothing happens, the selection still includes the space. How to fix this?
Trim should works as expected. Issue somewhere else.
Minimal working code
Dim sht As Worksheet
Set sht = Sheets("Sheet1")
Dim value1, value2 As String
value1 = sht.Cells(1, 1)
value2 = RTrim(LTrim(value1))
value3 = Trim(Trim(value1))
MsgBox ("'" + value1 + "'" + vbCrLf + "'" + value2 + "'" + vbCrLf + "'" + value3 + "'")
Result from value2 is equal to result from value3
Code for the Word:
Double click on the word, then run the macro. This should select text only.
Sub Makro2()
Dim r1 As Range
Dim str1 As String
Dim a As Integer
Dim b As Integer
Set r1 = Selection.Range
str1 = Trim(r1.Text)
a = r1.Start
b = Len(Trim(r1.Text))
r1.SetRange Start:=a, End:=a + b
r1.Select
End Sub
Related
Any help here would be appreciated please.
The included VBA code almost meets the intended purpose, however, I need a solution that enables the use of wildcards and highlights all parameters contained between "##", "%%" or potentially other special characters (special characters included).
For instance, lets say in the cell range B2:B10 we would find something like:
Checked at ##date1## and ##hour1##
But I want to be able to do a search and highlight using # * # or % * % within a selected determined cell range with the end result (bold being color):
Checked at ##date1## and ##hour1##
Sub HighlightStrings()
Application.ScreenUpdating = False
Dim Rng As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
Dim xFNum As Integer
Dim xArrFnd As Variant
Dim xStr As String
cFnd = InputBox("Please enter the text, separate them by comma:")
If Len(cFnd) < 1 Then Exit Sub
xArrFnd = Split(cFnd, ",")
For Each Rng In Selection
With Rng
For xFNum = 0 To UBound(xArrFnd)
xStr = xArrFnd(xFNum)
y = Len(xStr)
m = UBound(Split(Rng.Value, xStr))
If m > 0 Then
xTmp = ""
For x = 0 To m - 1
xTmp = xTmp & Split(Rng.Value, xStr)(x)
.Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
xTmp = xTmp & xStr
Next
End If
Next xFNum
End With
Next Rng
Application.ScreenUpdating = True
End Sub
Thank you
Okay This seems to work for me. There is a limitation we can work on if required: the phrase to highlight must be padded with spaces on both sides.
Option Explicit
Option Base 0
Sub testreplace()
Dim I As Integer 'Iteration
Dim FlagNum As Integer 'Flag Number
Dim RG As Range 'Whole range
Dim CL As Range 'Each Cell
Dim FlagChar As String 'Flag characters
Dim ArrFlag 'Flag Char Array
Dim TextTemp As String 'Cell Contents
Set RG = Selection
FlagChar = "##"
FlagChar = InputBox("Enter 'Flag Characters' separated by a comma." & vbCrLf & vbCrLf & _
"Example:" & vbCrLf & vbCrLf & _
"##,%%,&&" & vbCrLf & _
"$$,XX", "Flag Characters to Highlight", "##,%%")
ArrFlag = Split(FlagChar, ",")
For Each CL In RG.Cells
TextTemp = CL.Value
For FlagNum = 0 To UBound(ArrFlag)
For I = 1 To Len(TextTemp)
'Debug.Print "<<" & Mid(TextTemp, I, Len(ArrFlag(Flagnum)) + 1) & _
"=" & " " & ArrFlag(Flagnum) & ">>"
If Mid(TextTemp, I, Len(ArrFlag(FlagNum)) + 1) = " " & ArrFlag(FlagNum) Then
CL.Characters(I + 1, InStr(I, TextTemp, ArrFlag(FlagNum) & " ") + _
Len(ArrFlag(FlagNum)) - I).Font.ColorIndex = 3
End If
Next I
Next FlagNum
Next CL
End Sub
Here's an example of it working:
So... I have this form where people select different controls (We call safety measures controls, these are not content controls) from a listbox and add them to a list. This is in a repeating table. Each control has a heading label (either "engineering" "administrative" or "PPE" that I want to make bold and underlined but I want the options selected in the listboxes to be in normal formatting.
the portion of code that is printing this to the document looks like this:
Set tableSequence = ActiveDocument.Tables(1)
Set NewRow = tableSequence.Rows.Add
NewRow.Cells(5).Range.Text = "Engineering: " & MyString3 _
& vbCrLf & "Administrative: " _
& MyString4 & vbCrLf _
& "PPE: " & MyString5
I want the words Engineering, Administrative, and PPE to be bold and underlined, and the items represented by the MyString objects to appear in standard formatting. Thank you.
The string portion is as follows:
Private Sub CommandButton6_Click()
Dim tableSequence As Table
Dim NewRow As Row
Dim MyString5 As String
Dim v As Variant
Dim var3
Dim p As String
Dim M As Long
For var3 = 0 To ListBox7.ListCount - 1
If ListBox7.Selected(var3) = True Then
MyString5 = MyString5 & ListBox7.List(var3)
v = Split(MyString5, ",")
p = ""
For M = LBound(v) To UBound(v)
p = p + v(M)
If M Mod 3 = 2 Then
p = p + vbCr
Else
p = p + ","
End If
Next M
p = Left(p, Len(p) - 1)
Debug.Print p
End If
sorry for leaving that out
How to format a part (or multiple parts) of a Cell's Value in a Word table:
I have to admit i am not very fond of Word VBA, but i stitched this Sub together for you and it works in my test document. Adjust it to your needing.
Option Explicit
Sub asd()
Dim tableSequence As Table
Set tableSequence = ActiveDocument.Tables(1)
Dim NewRow As Row
Set NewRow = tableSequence.Rows.Add
NewRow.Cells(5).Range.Text = "Engineering: asd" & vbCrLf & "Administrative: vvv" & vbCrLf & "test" & vbCrLf & "PPE: blabla"
NewRow.Cells(5).Range.Bold = False
NewRow.Cells(5).Range.Underline = False
Dim keywordArr As Variant
keywordArr = Array("Engineering:", "Administrative:", "PPE:")
Dim keyword As Variant
Dim myRange As Variant
Dim startPos As Integer
Dim endPos As Integer
Dim length As Integer
Dim i As Integer
i = 1
For Each keyword In keywordArr
Do While InStr(1, myRange, keyword) = 0
Set myRange = NewRow.Cells(5).Range.Paragraphs(i).Range
i = i + 1
Loop
startPos = InStr(1, myRange, keyword)
startPos = myRange.Characters(startPos).Start
length = Len(keyword)
endPos = startPos + length
Set myRange = ActiveDocument.Range(startPos, endPos)
With myRange.Font
.Bold = True
.Underline = True
End With
Next keyword
End Sub
Below is a solution for the same thing in Excel:
First off you would have to write the text into the cell just like you already do.
Next would be to find the position of your keywords in the cell's value + the length of your keywords like so
startPos = Instr(1, NewRow.Cells(5), "Engineering:")
length = len("Engineering:")
Then you can set up the Font of the found substring via Range.Characters.Font
NewRow.Cells(5).Characters(startPos, Length).Font.Bold = True
NewRow.Cells(5).Characters(startPos, Length).Font.Underline = True
Now the elegant way would be to have an array of keywords and iterate through them to change the font for all them
Dim keywordArr As Variant
keywordArr = Array("Engineering:", "Administrative:", "PPE:")
Dim keyword As Variant
Dim startPos as Integer
Dim length as Integer
For Each keyword In keywordArr
startPos = InStr(1, NewRow.Cells(5), keyword)
length = Len(keyword)
With NewRow.Cells(5).Characters(startPos, Length).Font
.Bold = True
.Underline = True
End With
Next keyword
I was wondering how to remove duplicate names/text's in a cell. For example
Jean Donea Jean Doneasee
R.L. Foye R.L. Foyesee
J.E. Zimmer J.E. Zimmersee
R.P. Reed R.P. Reedsee D.E. Munson D.E. Munsonsee
While googling, I stumbled upon a macro/code, it's like:
Function RemoveDupes1(pWorkRng As Range) As String
'Updateby20140924
Dim xValue As String
Dim xChar As String
Dim xOutValue As String
Set xDic = CreateObject("Scripting.Dictionary")
xValue = pWorkRng.Value
For i = 1 To VBA.Len(xValue)
xChar = VBA.Mid(xValue, i, 1)
If xDic.exists(xChar) Then
Else
xDic(xChar) = ""
xOutValue = xOutValue & xChar
End If
Next
RemoveDupes1 = xOutValue
End Function
The macro is working, but it is comparing every letter, and if it finds any repeated letters, it's removing that.
When I use the code over those names, the result is somewhat like this:
Jean Dos
R.L Foyes
J.E Zimers
R.P edsDEMuno
By looking at the result I can make out it is not what I want, yet I got no clue how to correct the code.
The desired output should look like:
Jean Donea
R.L. Foye
J.E. Zimmer
R.P. Reed
Any suggestions?
Thanks in Advance.
Input
With the input on the image:
Result
The Debug.Print output
Regex
A regex can be used dynamically iterating on the cell, to work as a Find tool. So it will extract only the shortest match. \w*( OUTPUT_OF_EXTRACTELEMENT )\w*, e.g.: \w*(Jean)\w*
The Regex's reference must be enabled.
Code
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
On Error GoTo ErrHandler:
EXTRACTELEMENT = Split(Application.Trim(Mid(Txt, 1)), Separator)(n - 1)
Exit Function
ErrHandler:
' error handling code
EXTRACTELEMENT = 0
On Error GoTo 0
End Function
Sub test()
Dim str As String
Dim objMatches As Object
Set objRegExp = CreateObject("VBScript.RegExp") 'New regexp
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For Row = 1 To lastrow
str = Range("A" & Row)
F_str = ""
N_Elements = UBound(Split(str, " "))
If N_Elements > 0 Then
For k = 1 To N_Elements + 1
strPattern = "\w*(" & EXTRACTELEMENT(CStr(str), k, " ") & ")\w*"
With objRegExp
.Pattern = strPattern
.Global = True
End With
If objRegExp.test(strPattern) Then
Set objMatches = objRegExp.Execute(str)
If objMatches.Count > 1 Then
If objRegExp.test(F_str) = False Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
ElseIf k <= 2 And objMatches.Count = 1 Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
End If
Next k
Else
F_str = str
End If
Debug.Print Trim(F_str)
Next Row
End Sub
Note that you can Replace the Debug.Print to write on the target
cell, if it is column B to Cells(Row,2)=Trim(F_str)
Explanation
Function
You can use this UDF, that uses the Split Function to obtain the element separated by spaces (" "). So it can get every element to compare on the cell.
Loops
It will loop from 1 to the number of elements k in each cell and from row 1 to lastrow.
Regex
The Regex is used to find the matches on the cell and Join a new string with the shortest element of each match.
This solution operates on the assumption that 'see' (or some other three-letter string) will always be on the end of the cell value. If that isn't the case then this won't work.
Function RemoveDupeInCell(dString As String) As String
Dim x As Long, ct As Long
Dim str As String
'define str as half the length of the cell, minus the right three characters
str = Trim(Left(dString, WorksheetFunction.RoundUp((Len(dString) - 3) / 2, 0)))
'loop through the entire cell and count the number of instances of str
For x = 1 To Len(dString)
If Mid(dString, x, Len(str)) = str Then ct = ct + 1
Next x
'if it's more than one, set to str, otherwise error
If ct > 1 Then
RemoveDupeInCell = str
Else
RemoveDupeInCell = "#N/A"
End If
End Function
the code below is part of a larger Macro, all variables have been specified earlier on but this is the part i'm having the problem with. it's basically meant to loop through a column of company Names and for each company, add up all charges to that company listed on another workbook (essentially like a cost summary for each). Everything seems to work fine except the two rows with ** next to them, here im getting the "Invalid Procedure Call or argument" error and im not sure why. This particular section is meant to compare only the first word in a company name on each workbook (this means different branches are also summed up for a head office total, e.g. so "Company x Group" would include "Company x Manchester" and "Company x London" in its total).
I've tested the two problematic lines in a smaller test macro to see if it actually does represent the first word of the string and it works fine but when i try to use it in this larger macro this is the part that stops it working.
I'm very new to VBA so i understand if the code is a bit clunky and messy but any help would be greatly appreciated. Also apologies for the long winded explanation.
Thanks in Advance!
(the "If Not" part is so only companies that have had sales in this particular week but do not have an amount next to it are taken through the extra loop i.e. "number of sales" isn't empty but "money made" is 0)
Dim AgeName As Range
Dim AgeNameB As Range
Dim AgeNameAdd As String
Dim Lrow As Long
Dim J As Integer
Dim K As Double
Dim PostingRange As Range
Dim Postingaddress As String
Dim MarginValueBook As String
Dim MarginValueSheet As String
Dim WENum As String
Dim Postinglocation As Range
Dim L As Integer
Dim M As Double
Dim FirstNameAgeA As String
Dim FirstNameAgeB As String
Dim WENumb As String
Dim AgeComparison As String
Dim FirstWordArrA As String
Dim FirstWordArrB As String
MarginValueBook = "W.E. " & Format(dtTestDate, "DD.MM") & ".csv"
MarginValueSheet = "W.E. " & Format(dtTestDate, "DD.MM")
For i = 2 To y
K = 0
Workbooks("Average Margin Data.xlsm").Activate
Set ws = ThisWorkbook.Worksheets("Breakdown")
Set AgeName = ws.Range(celladdress).Offset(i)
AgeNameAdd = AgeName.Address
Set PostingRange = Range(AgeNameAdd).Offset(0, 3)
Postingaddress = PostingRange.Address
Workbooks(MarginValueBook).Activate
Set ws = Worksheets(MarginValueSheet)
Lrow = ActiveSheet.UsedRange.Rows.Count
For J = 2 To Lrow
WENum = "A" & J
If ws.Range(WENum) = UCase(AgeName) Then
K = K + ws.Range(WENum).Offset(0, 4).Value
End If
Next J
Set Postinglocation = Range(Postingaddress).Resize(1, 1)
Postinglocation.Value = K
Set ws = ThisWorkbook.Worksheets("Breakdown")
If Not ws.Range(AgeNameAdd).Offset(0, 2) = "" Then
If ws.Range(AgeNameAdd).Offset(0, 3) = 0 Then
For L = 2 To Lrow
Set AgeName = ws.Range(celladdress).Offset(i)
FirstWordArrA = AgeName.Value
'FirstNameAgeA = Trim$(Left$(FirstWordArrA, InStr(FirstWordArrA, " ") - 1))
AgeComparison = UCase(FirstNameAgeA)
Set wb = Workbooks(MarginValueBook)
Set ws = wb.Worksheets(MarginValueSheet)
WENumb = "A" & L
Set AgeNameB = ws.Range(WENumb)
FirstWordArrB = AgeNameB.Value
'FirstNameAgeB = Trim$(Left$(FirstWordArrB, InStr(FirstWordArrB, " ") - 1))
If AgeComparison = FirstNameAgeB Then
M = M + ws.Range(WENumb).Offset(0, 4).Value
End If
Next L
Set Postinglocation = Range(Postingaddress).Resize(1, 1)
Postinglocation.Value = M
M = 0
End If
End If
Next i
End Sub
Look at the InStr values. Someone might be null. Try to put a onError statement in order to return the correct value.
I am trying to generate map from GCmap.com using the VBA code.
I do have a long list of airport pairs in one column. The format of the hyperlink that will generate the map will be:
"http://www.gcmap.com/map?P="&(calue in .cell(1.51))&"%0d%0a"&(calue in .cell(2.51)& so on ...
' the %0d%0a - is a separator that needs to be between values
the problem is that this list is a quite long and just doing simple loop will cause enormous length of hyperlink (sometimes too long to generate the map) so it must be something like
if valueOfFirstCell = ValueOfCellBellow then
' skip to next one
I've tried this (probably worst ever written code, but please note that I am only beginner in VBA :)
Sub hyperlinkgenerator()
Dim separator As String ' declared the 'separator' value
separator = "%0d%0a"
Dim datarow, irow As Integer
Dim myval as Range
With Sheets("Direct flights")
Set myval = .Cells(datarow, 51)
Do While myval <> "" ' do until last empty row
Dim Value1 As String
Value1 = Sheets("Direct flights").Cells(datarow, 51) ' declare value of the first cell
Dim Value2 As String
Value2 = Sheets("Direct flights").Cells(datarow + 1, 51) ' declare value of cell bellow
If Value1 = Value2 Then
datarow = datarow + 1
Else: 'enter Value1 in hyperlink that is followed by & separator
'also the hyperlink must start with: http://www.gcmap.com/map?P=
' and end with %0d%0a&MS=wls&MR=540&MX=720x360&PM=*
End If
datarow = datarow + 1
Loop
End With
End Sub
The final link will look like:
http://www.gcmap.com/map?P=LGW-AMS%0d%0aAMS-LHR%0d%0aLCY-AMS%0d%0aLUX-AMS%0d%0aBRE-AMS%0d%0aCWL-AMS%0d%0aNUE-AMS%0d%0aAMS-JFK%0d%0a&MS=wls&MR=540&MX=720x360&PM=*
I don't have a clue how to keep loop adding new and new text into Hyperlink. Also hyperlink should be generated by and opened once user will click on button (that is easy to do).
Many thanks in advance!
Give this a try:
Sub hyperlinkgenerator()
Dim thisVal As String
Dim nextVal As String
Dim currentRow As Long
Dim hyperlink As String
currentRow = 1 ' or whatever the first row is
hyperlink = ""
With Sheets("Direct flights")
Do While True
thisVal = .Cells(currentRow, 1).Value
nextVal = .Cells(currentRow + 1, 1).Value
If thisVal = "" Then
Exit Do
ElseIf thisVal <> nextVal Then
hyperlink = hyperlink & thisVal & "%0d%0a"
End If
currentRow = currentRow + 1
Loop
End With
hyperlink = "http://www.gcmap.com/map?P=" & hyperlink & "&MS=wls&MR=540&MX=720x360&PM="
MsgBox hyperlink
End Sub