This is an extract form an excel 2010 macro I’m working on in VBA, the function I’m having issues with is DelStrikethroughs
Whenever the value in a cell is "TRUE", "FALSE", or "#N/A" (when its "#N/A" the macro crashes) the function returns a null string. Upon further investigation it looks like the variable x.text is always blank and has the error "Unable to get the text property of the characters class" when i try to debug it.
Any ideas on how to fix this? (I'm happy for the function to return the original text if it cant remove the strike through text, but a proper solution is preferred)
Below is the code sample:
Sub testx()
Dim testRange As Range
Set testRange = selection
Call DelStrikethroughs(testRange.Cells(1, 1))
End Sub
Function DelStrikethroughs(Cell As Range) As String
'Returns the text value of a cell with strikethrough characters removed
Dim NewText As String
Dim iCh As Integer
For iCh = 1 To Len(Cell)
Dim x As Characters
Set x = Cell.Characters(iCh, 1)
On Error Resume Next '"On Error" is here to deal with blank characters
If x.Font.Strikethrough = False Then
NewText = NewText & x.text
End If
If Err.Number = 0 Then
NewText = NewText
Else
NewText = NewText & x.text
End If
Next iCh
DelStrikethroughs = NewText
End Function
Try this:
Sub testx()
Dim testRange As Range, c As Range
Set testRange = Selection
For Each c In testRange
c.Offset(0, 1).Value = DelStrikethroughs(c)
Next c
End Sub
Function DelStrikethroughs(Cell As Range) As String
'Returns the text value of a cell with strikethrough characters removed
Dim NewText As String
Dim iCh As Long, l As Long, ch As Characters
On Error Resume Next
l = Cell.Characters.Count
On Error GoTo 0
If l = 0 Then
NewText = Cell.Text
Else
For iCh = 1 To l
Set ch = Cell.Characters(iCh, 1)
NewText = NewText & IIf(ch.Font.Strikethrough, "", ch.Text)
Next iCh
End If
DelStrikethroughs = NewText
End Function
If all you want to do is return the text in the cell without any strikethrough, then try:
Function DelStrikethroughs(Cell As Range) As String
DelStrikethroughs = Cell.Text
End Function
Related
is there I way for searching a value on the next sheet (ActiveSheet.Next.Activate) without jumping on to it?
Here the whole Code:
the problem is, it jumps to the next sheet even if there is no searched value.
Dim ws As Worksheet
Dim Loc As Range
Dim StrVal As String
Dim StrRep As String
Dim i As Integer
Private Sub CommandButton1_Click()
i = 1
Call Replacing
End Sub
Private Sub CommandButton2_Click()
i = 2
Call Replacing
End Sub
Public Sub Replacing()
StrVal = Userform1.Textbox1.Text
StrRep = Me.Textbox1.Text
if Trim(StrVal) = "" Then Exit Sub
Dim fstAddress As String
Dim nxtAddress As String
For Each ws In ThisWorkbook.Worksheets
With ws
Set Loc = .Cells.Find(what:=StrVal)
fstAddress = Loc.Address
If Not Loc Is Nothing Then
If Not StrRep = "" And i = 1 Then
Loc.Value = StrRep
Set Loc = .Cells.FindNext(Loc)
ElseIf i = 2 Then Set Loc = Range(ActiveCell.Address)
Set Loc = .Cells.FindNext(Loc)
nxtAddress = Loc.Address
If Loc.Address = fstAddress Then
ActiveSheet.Next.Activate '****Here it should jump only if found something on the next sheet****
GoTo repeat
nxtAddress = Loc.Address
End If
If Not Loc Is Nothing Then Application.Goto ws.Range(nxtAddress), False
End If
i = 0
End If
End With
Set Loc = Nothing
repeat:
Next ws
End Sub
the variable "i" which switches between the values 0, 1 and 2 is bound to two buttons. these buttons are "Replace" and "Skip (to next found value)".
This code asks on each occurrence of StrVal whether you want to replace the value or skip it.
I found a problem checking if Found_Address = First_Found_Address:
If you've replaced the value in in First_Found_Address it won't find that address again and miss the starting point in the loop.
Also the original source of the code stops at the last value using Loop While Not c Is Nothing And c.Address <> firstAddress. The problem here is that if the value in c is being changed eventually c will be Nothing but it will still try and check the address of c - causing an error (Range Find Method).
My solution to this is to build up a string of visited addresses on the sheet and checking if the current address has already been visited using INSTR.
I've included the code for calling from a button click or from within another procedure.
Private Sub CommandButton1_Click()
FindReplace Userform1.Textbox1.Text, 1
End Sub
Private Sub CommandButton2_Click()
FindReplace Userform1.Textbox1.Text, 1, Me.Textbox1.Text
End Sub
Sub Test()
FindReplace "cd", 1, "ab"
End Sub
Sub FindReplace(StrVal As String, i As Long, Optional StrRep As String = "")
Dim ws As Worksheet
Dim Loc As Range
Dim fstAddress As String
Dim bDecision As Variant
For Each ws In ThisWorkbook.Worksheets
'Reset the visited address list on each sheet.
fstAddress = ""
With ws
Set Loc = .Cells.Find(what:=StrVal, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Loc Is Nothing Then
Do
fstAddress = fstAddress & "|" & Loc.Address
Loc.Parent.Activate 'Activate the correct sheet.
Loc.Activate 'and then the cell on the sheet.
bDecision = MsgBox("Replace value?", vbYesNo + vbQuestion, "Replace or Select value?")
If bDecision = vbYes Then
Loc = StrRep 'Raise the blade, make the change.
'Re-arrange it 'til it's sane.
End If
Set Loc = .Cells.FindNext(Loc)
If Loc Is Nothing Then Exit Do
Loop While InStr(fstAddress, Loc.Address) = 0
End If
End With
Next ws
End Sub
I have a VBA function in Excel returns a concatenated string of text from cells selected by users.
This works as I require, however if there are hidden cells in the selection, the value of the hidden cell is included, which is undesirable. An example of when this issue occurs is when a table is filtered.
Is there a way to amend my function to check if the cell that is being read is visible?
Sub ConcatEmialAddresses()
Dim EmailAddresses As String
ActiveSheet.Range("C3").Value = combineSelected()
ActiveSheet.Range("C3").Select
Call MsgBox("The email address string from cell ""C3"" has been copied to your clipboard.", vbOKOnly, "Sit back, relax, it's all been taken care of...")
End Sub
Function combineSelected(Optional ByVal separator As String = "; ", _
Optional ByVal copyText As Boolean = True) As String
Dim cellValue As Range
Dim outputText As String
For Each cellValue In Selection
outputText = outputText & cellValue & separator
Next cellValue
If Right(outputText, 2) = separator Then outputText = Left(outputText, Len(outputText) - 2)
combineSelected = outputText
End Function
To determine if a Range has an hidden cell, I would check that the height/width of each row/column is different from zero:
Function HasHiddenCell(source As Range) As Boolean
Dim rg As Range
'check the columns
If VBA.IsNull(source.ColumnWidth) Then
For Each rg In source.Columns
If rg.ColumnWidth = 0 Then
HasHiddenCell = True
Exit Function
End If
Next
End If
' check the rows
If VBA.IsNull(source.RowHeight) Then
For Each rg In source.rows
If rg.RowHeight = 0 Then
HasHiddenCell = True
Exit Function
End If
Next
End If
End Function
Sub UsageExample()
If HasHiddenCell(selection) Then
Debug.Print "A cell is hidden"
Else
Debug.Print "all cells are visible"
End If
End Sub
I used this
Function areCellsHidden(Target As Range)
areCellsHidden = False
If (Target.Rows.Hidden = True) Then
areCellsHidden = True
ElseIf (Target.Columns.Hidden = True) Then
areCellsHidden = True
ElseIf (Target.Count > 1) Then
If _
Target.Count <> Target.Columns.SpecialCells(xlCellTypeVisible).Count _
Or Target.Count <> Target.Rows.SpecialCells(xlCellTypeVisible).Count _
Then
areCellsHidden = True
End If
End If
End Function
I am writing a VBA program that will allow me to mine through a set of Excel data and pull out relevant information which is then copied to another sheet.
I keep trying to make it so that the word that is being searched for is highlighted in yellow, however my program constantly throws "Compile error - expected array on Ubound".
Option Compare Text
Public Sub Textchecker()
'
' Textchecker
'
' Keyboard Shortcut: Ctrl+h
'
Dim Continue As Long
Dim findWhat As String
Dim LastLine As Long
Dim toCopy As Boolean
Dim cell As Range
Dim item As Long
Dim j As Long
Dim sheetIndex As Long
Dim inclusion As String
sheetIndex = 2
Continue = vbYes
Do While Continue = vbYes
findWhat = CStr(InputBox("What word would you like to search for today?"))
inclusion = CStr(InputBox("Do you have any inclusions? Separate words with commas"))
LastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For item = 1 To LastLine
If UBound(inclusion) >= 0 Then
For Each cell In Range("BY1").Offset(item - 1, 0) Then
For Each item In inclusion
If InStr(cell.Text, findWhat) <> 0 And InStr(cell.Text, inclusion) <> 0 Then
findWhat.Interior.Color = 6
toCopy = True
Else
For Each cell In Range("BY1").Offset(item - 1, 0) Then
If InStr(cell.Text, findWhat) <> 0 Then
findWhat.Interior.Color = 6
toCopy = True
End If
Next item
End If
Next
If toCopy = True Then
Sheets(sheetIndex).Name = UCase(findWhat) + "+" + LCase(inclusion)
Rows(item).Copy Destination:=Sheets(sheetIndex).Rows(j)
j = j + 1
End If
toCopy = False
Next item
sheetIndex = sheetIndex + 1
Continue = MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion)
Loop
End Sub
What am I doing wrong here?
In your code, inclusion is declared as a String variable, and contains a String, albeit a String separated by commas. The Ubound function works on arrays.
To fix: Convert the string into an array using the Split function. See the below example for some quick help, and let us know if you need more details.
Sub Tests()
Dim inclusion() As String
inclusion = Split("One, Two, Three", ",")
MsgBox (UBound(inclusion))
End Sub
To answer your last comment.
A variable in For Each must be of type Object or Variant.
To change your 'item' in a Variant, replace 'Dim item As Long' by 'Dim item As Variant', or even by 'Dim item' as a variable declared without a type is a Variant.
In a VBA Word macro, I'd like to get a Field-object for the field which contains the cursor.
The obvious try fails:
Private Sub Try1()
MsgBox Selection.Fields.Count
End Sub
The array is empty. Then I tried:
Private Sub Try2()
Dim oRange As Range
Set oRange = Selection.GoTo(What:=wdGoToField)
MsgBox oRange
End Sub
The cursor does not move, the message is empty.
I can iterate over ActiveDocument.Fields, compare the ranges and find the containing fiels. But probably there is a simple direct way?
My current production code with iteration over Document.Fields:
Sub Test()
Dim oField As Field
Set oField = FindWrappingField(Selection.Range)
If oField Is Nothing Then
MsgBox "not found"
Else
MsgBox oField
End If
End Sub
Private Function FindWrappingField(vRange As Range)
Dim oField As Field
Dim nRefPos As Long
' If selection starts inside a field, it also finishes inside.
nRefPos = vRange.Start
' 1) Are the fields sorted? I don't know.
' Therefore, no breaking the loop if a field is too far.
' 2) "Code" goes before "Result", but is it forever?
For Each oField In vRange.Document.Fields
If ((oField.Result.Start <= nRefPos) Or (oField.Code.Start <= nRefPos)) And _
((nRefPos <= oField.Result.End) Or (nRefPos <= oField.Code.End)) Then
Set FindWrappingField = oField
Exit Function
End If
Next oField
Set FindWrappingField = Nothing
End Function
The following function determines whether the selection spans or is within a field.
Function WithInField(Rng As Word.Range) As Boolean
' Based on code by Don Wells: http://www.eileenslounge.com/viewtopic.php?f=30&t=6622
' Approach : This procedure is based on the observation that, irrespective of _
a field's ShowCodes state, toggling the field's ShowCodes state _
twice collapses the selection to the start of the field.
Dim lngPosStart As Long, lngPosEnd As Long, StrNot As String
WithInField = True
Rng.Select
lngPosStart = Selection.Start
lngPosEnd = Selection.End
With Selection
.Fields.ToggleShowCodes
.Fields.ToggleShowCodes
' Test whether the selection has moved; if not, it may already have been _
at the start of a field, in which case, move right and test again.
If .Start = lngPosStart Then
.MoveRight
.Fields.ToggleShowCodes
.Fields.ToggleShowCodes
If .Start = lngPosStart + 1 Then
WithInField = False
End If
End If
End With
End Function
You can use the function with code like:
Sub TestWithInField()
Dim Rng As Word.Range, c As Word.Range, StrRslt As String
Set Rng = Selection.Range
For Each c In Rng.Characters
StrRslt = StrRslt & c.Text & ",WithInField:" & WithInField(Rng:=c) & vbCr
Next
Rng.Select
MsgBox StrRslt
End Sub
I had the same problem and I solved with the code below:
Sub Test()
NumberOfFields = Selection.Fields.Count
While NumberOfFields = 0
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
NumberOfFields = Selection.Fields.Count
Wend
End Sub
Of course, I have to know that the cursor is in a field.
Apparently, when you select a range extending to the right, at some moment the field will be selected. The end of the range doesn't count (it not acuses a field range)
I use this code
Sub GetFieldUnderCursor()
Dim NumberOfFields As Integer
Dim oFld As Field
Dim TextFeld As String
Dim Typ As Integer
Dim pos As Integer
Dim NameOfField As String
'update field. Cursor moves after the field
Selection.Fields.Update
'select the field
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'check if there is a field
NumberOfFields = Selection.Fields.Count
If NumberOfFields = 0 Then
MsgBox "No field under cursor"
Exit Sub
End If
Set oFld = Selection.Fields(1)
TextFeld = Trim(oFld.Code.Text)
Typ = oFld.Type '85 is DOCPROPERTY, 64 is DOCVARIABLE
If Typ = 85 Or Typ = 64 Then
pos = InStr(15, TextFeld, " ")
If pos > 0 Then
NameOfField = Trim(Mid(TextFeld, 12, pos - 11))
MsgBox NameOfField
End If
End If
End Sub
We have migrated a server and transferred the files over using the same share path. My customer has got a word document with hyperlinks in it which point to the older server name.
i.e.
\\serverOld\accounts\1234.pdf and \\serverNew\accounts\1234.pdf
I have found this VB Script below that has done what i need but it is for Excel not Word.
Sub HyperLinkChange()
Dim oldtext As String
Dim newtext As String
Dim h As Hyperlink
' These can be any text portion of a hyperlink, such as ".com" or ".org".
oldtext = "\\topscan-server"
newtext = "\\ts-sbs"
' Check all hyperlinks on active sheet.
For Each h In ActiveSheet.Hyperlinks
x = InStr(1, h.Address, oldtext)
If x > 0 Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Application.WorksheetFunction. _
Substitute(h.Address, oldtext, newtext)
End If
Next
End Sub
Please can someone help me edit this text to work with Microsoft Word 2010?
Try this
Sub HyperLinkChange()
Dim oldtext As String, newtext As String
Dim h As Hyperlink
oldtext = "\\topscan-server"
newtext = "\\ts-sbs"
For Each h In ActiveDocument.Hyperlinks
If InStr(1, h.Address, oldtext) Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Replace(h.Address, oldtext, newtext)
End If
Next
End Sub