Sub FindInShapes1()
Dim rStart As Range
Dim shp As Shape
Dim sFind As String
Dim sTemp As String
Dim Response
sFind = InputBox("Search for?")
If Trim(sFind) = "" Then
MsgBox "Nothing entered"
Exit Sub
End If
Set rStart = ActiveCell
For Each shp In ActiveSheet.Shapes
sTemp = shp.TextFrame.Characters.Text
If InStr(LCase(sTemp), LCase(sFind)) <> 0 Then
shp.Select
Response = MsgBox( _
prompt:=shp.TopLeftCell & vbCrLf & _
sTemp & vbCrLf & vbCrLf & _
"Do you want to continue?", _
Buttons:=vbYesNo, Title:="Continue?")
If Response <> vbYes Then
Set rStart = Nothing
Exit Sub
End If
End If
Next
MsgBox "No more found"
rStart.Select
Set rStart = Nothing
End Sub
Hi,
I made the above Macro for finding excel shapes in a "crouded" worksheet, by the text written inside. The macro works in any new books but not in the one I need, were it keeps on showing the following message:
"Run-Time error '1004'
The specified value is out of range"
and as soon as i click on "Debug" it highlights the line:
sTemp = shp.TextFrame.Characters.Text
What's wrong?
Thanks for your help
Chiara
Sorry to break the convention but the similar error I get:
The specified value is out of range
Run-time error -2147024809
In my scenario I am simply returning a shape as part of a GET property in side a class that store a Shape Object. The property works for Shape Type Text Boxes but craps out on sending back Line Shapes. As per below.
I cannot use the on error, Or don't know how because the error occur at End Property?
Public Property Get shp_Obj() As Shape
If prvt_int_Ordinal = 13 Them
MsgBox prvt_Shp_Shape.Name, , "prvt_Shp_Shape.Name"
Set shp_Obj = prvt_Shp_Shape
End If
End Property
I think as there is no way to check for the existence of a TextFrame within a shape, you should ignore the error by using On Error Resume Next:
Sub FindInShapes1()
Dim rStart As Range
Dim shp As Shape
Dim sFind As String
Dim sTemp As String
Dim Response
On Error Resume Next
sFind = InputBox("Search for?")
If Trim(sFind) = "" Then
MsgBox "Nothing entered"
Exit Sub
End If
Set rStart = ActiveCell
For Each shp In ActiveSheet.Shapes
'If shp.TextFrame.Characters.Count > 0 Then
If InStr(LCase(sTemp), LCase(sFind)) <> 0 Then
shp.Select
Response = MsgBox( _
prompt:=shp.TopLeftCell & vbCrLf & _
sTemp & vbCrLf & vbCrLf & _
"Do you want to continue?", _
Buttons:=vbYesNo, Title:="Continue?")
If Response <> vbYes Then
Set rStart = Nothing
Exit Sub
End If
End If
'End If
sTemp = shp.TextFrame.Characters.Text
Next
MsgBox "No more found"
rStart.Select
Set rStart = Nothing
End Sub
`
There is nothing wrong with your code. You will only get this error if the Active worksheet is password protected.
Can you check that?
Also check below url from so
Excel macro "Run-time error '1004"
Related
I keep getting this error for some code I am adapting. I have used this in other workbooks without issue as shown. The line "Me.Controls("Reg" & X).Value = findvalue" is where I am getting stuck. I use this throughout my project again without issue in other projects. Any ideas?
Private Sub lstLookup_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'Search new and existing training and return data to user controls at the bottom of the form
'declare the variables
Dim ID As String
Dim I As Integer
Dim findvalue
'error block
On Error GoTo errHandler:
'get the select value from the listbox
For I = 0 To lstLookup.ListCount - 1
If lstLookup.Selected(I) = True Then
'set the listbox column
ID = lstLookup.List(I, 8)
End If
Next I
'find the value in the range
Set findvalue = Sheet2.Range("J:J").Find(What:=ID, LookIn:=xlValues).Offset(0, -8)
'add the values to the userform controls
cNum = 9
For X = 1 To cNum
**Me.Controls("Reg" & X).Value = findvalue**
Set findvalue = findvalue.Offset(0, 1)
Next
'disable controls force user to select option
'error block
On Error GoTo 0
Exit Sub
errHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
I was using the script which I found here : https://excelribbon.tips.net/T008349_Counting_All_Characters.html
It is working as expected however when there are some other objects like pictures, the script returns me the error 438"Object Doesn't Support This Property or Method".
When I deleted the pictures the script was working well again.
Is there an option to put in the script something like "ignore pictures"? Or is there any better type of script to achieve this? I am not good at all at VBA, all help will be much appreciated.
Here's a simplified approach that may work out a bit better. I think being explicit which Shape Types you want to count is going to be a cleaner way of going about this.
Option Explicit
Private Function GetCharacterCount() As Long
Dim wks As Worksheet
Dim rng As Range
Dim cell As Range
Dim shp As Shape
For Each wks In ThisWorkbook.Worksheets
For Each shp In wks.Shapes
'I'd only add the controls I care about here, take a look at the Shape Type options
If shp.Type = msoTextBox Then GetCharacterCount = GetCharacterCount + shp.TextFrame.Characters.Count
Next
On Error Resume Next
Set rng = Union(wks.UsedRange.SpecialCells(xlCellTypeConstants), wks.UsedRange.SpecialCells(xlCellTypeFormulas))
On Error GoTo 0
If not rng Is Nothing Then
For Each cell In rng
GetCharacterCount = GetCharacterCount + Len(cell.Value)
Next
end if
Next
End Function
Sub CountCharacters()
Debug.Print GetCharacterCount()
End Sub
It looks like you can add an if-check like the one here (VBA Code to exclude images png and gif when saving attachments for "PNG" and "GIF".).
You just have to change the if-check to check for the picture type you're using "JPG" or "JPEG"? Simply match the extension to the if-check by replacing "PNG" or "GIF" with your extension in CAPS.
Add the if-check right above where the error is occurring or better yet, add it above the scope of where the error is occurring.
I took the script from your link and modified it. Now it works.
It's far from perfect (there're some cases where it can still crash), but now it supports handling Shapes with no .TextFrame property:
Sub CountCharacters()
Dim wks As Worksheet
Dim rng As Range
Dim rCell As Range
Dim shp As Shape
Dim bPossibleError As Boolean
Dim bSkipMe As Boolean
Dim lTotal As Long
Dim lTotal2 As Long
Dim lConstants As Long
Dim lFormulas As Long
Dim lFormulaValues As Long
Dim lTxtBox As Long
Dim sMsg As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
lTotal = 0
lTotal2 = 0
lConstants = 0
lFormulas = 0
lFormulaValues = 0
lTxtBox = 0
bPossibleError = False
bSkipMe = False
sMsg = ""
For Each wks In ActiveWorkbook.Worksheets
' Count characters in text boxes
For Each shp In wks.Shapes
If TypeName(shp) <> "GroupObject" Then
On Error GoTo nextShape
lTxtBox = lTxtBox + shp.TextFrame.Characters.Count
End If
nextShape:
Next shp
On Error GoTo ErrHandler
' Count characters in cells containing constants
bPossibleError = True
Set rng = wks.UsedRange.SpecialCells(xlCellTypeConstants)
If bSkipMe Then
bSkipMe = False
Else
For Each rCell In rng
lConstants = lConstants + Len(rCell.Value)
Next rCell
End If
' Count characters in cells containing formulas
bPossibleError = True
Set rng = wks.UsedRange.SpecialCells(xlCellTypeFormulas)
If bSkipMe Then
bSkipMe = False
Else
For Each rCell In rng
lFormulaValues = lFormulaValues + Len(rCell.Value)
lFormulas = lFormulas + Len(rCell.Formula)
Next rCell
End If
Next wks
sMsg = Format(lTxtBox, "#,##0") & _
" Characters in text boxes" & vbCrLf
sMsg = sMsg & Format(lConstants, "#,##0") & _
" Characters in constants" & vbCrLf & vbCrLf
lTotal = lTxtBox + lConstants
sMsg = sMsg & Format(lTotal, "#,##0") & _
" Total characters (as constants)" & vbCrLf & vbCrLf
sMsg = sMsg & Format(lFormulaValues, "#,##0") & _
" Characters in formulas (as values)" & vbCrLf
sMsg = sMsg & Format(lFormulas, "#,##0") & _
" Characters in formulas (as formulas)" & vbCrLf & vbCrLf
lTotal2 = lTotal + lFormulas
lTotal = lTotal + lFormulaValues
sMsg = sMsg & Format(lTotal, "#,##0") & _
" Total characters (with formulas as values)" & vbCrLf
sMsg = sMsg & Format(lTotal2, "#,##0") & _
" Total characters (with formulas as formulas)"
MsgBox Prompt:=sMsg, Title:="Character count"
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
If bPossibleError And Err.Number = 1004 Then
bPossibleError = False
bSkipMe = True
Resume Next
Else
MsgBox Err.Number & ": " & Err.Description
Resume ExitHandler
End If
End Sub
You could try:
Option Explicit
Sub test()
Dim NoOfChar As Long
Dim rng As Range, cell As Range
NoOfChar = 0
For Each cell In ThisWorkbook.Worksheets("Sheet1").UsedRange '<- Loop all cell in sheet1 used range
NoOfChar = NoOfChar + Len(cell.Value) '<- Add cell len to NoOfChar
Next cell
Debug.Print NoOfChar
End Sub
I have a sub which opens an older version of a checklist I've created, and then imports the data. After the user selects the file, I want to check if a specific sheet and named cell on that sheet exists (for validation they have picked the correct file - the sheet will always be "Main Page" and the cell "Version"). If either doesn't exist, then I want a message box and to exit sub. If they both exist, then continue with the rest of the import.
Most of it works, it's just the first check for the named sheet/cell. The main problem is this bit of the sub:
If Not WorksheetExists("Main Page") Then
MsgBox "The selected file does not appear to be an older version of the checklist." & vbNewLine & vbNewLine & "Please check that you have selected the correct file."
wbCopyFrom.Close SaveChanges:=False
Exit Sub
End If
And the called function:
Function WorksheetExists(sName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
This function at the moment checks the sheet name fine. But I'm getting a little confused on how to check the cell name - do I need another function or can I just edit the above function to check for both at the same time? ie. I think I can change the line:
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
to include the cell name instead of the A1 bit.
The whole sub and other functions are below for context if that helps.
Sub ImportLists()
If MsgBox("The import process will take some time (approximately 10 minutes); please be patient while it is running. It is recommended you close any other memory-intensive programs before continuing. Click 'Cancel' to run at another time.", vbOKCancel) = vbCancel Then Exit Sub
Application.ScreenUpdating = False
Dim OldFile As Variant, wbCopyFrom As Workbook, wsCopyFrom As Worksheet, wbCopyTo As Workbook, wsCopyTo As Worksheet, OutRng As Range, c As Range, RangeName As Range
Set wbCopyTo = ActiveWorkbook
ChDir ThisWorkbook.Path
OldFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & "*.xls*", 1, "Select a previous version of the checklist", "Import", False)
If TypeName(OldFile) = "Boolean" Then
MsgBox "An error occured while importing the old version." & vbNewLine & vbNewLine & "Please check you have selected the correct checklist file and filetype (.xlsm)."
Exit Sub
End If
Set wbCopyFrom = Workbooks.Open(OldFile)
If Not WorksheetExists("Main Page") Then
MsgBox "The selected file does not appear to be an older version of the checklist." & vbNewLine & vbNewLine & "Please check that you have selected the correct file."
wbCopyFrom.Close SaveChanges:=False
Exit Sub
End If
OldVersion = Right(wbCopyFrom.Sheets("Main Page").Range("Version").Value, Len(wbCopyFrom.Sheets("Main Page").Range("Version").Value) - 1)
NewVersion = Right(wbCopyTo.Sheets("Main Page").Range("Version").Value, Len(wbCopyTo.Sheets("Main Page").Range("Version").Value) - 1)
If NewVersion < OldVersion Then
MsgBox "The selected older version of the checklist (v" & OldVersion & ") appears to be newer than the current version (v" & NewVersion & ")." & vbNewLine & vbNewLine & "Please check that you have selected the correct older version of the checklist or that the current checklist is not an older version."
wbCopyFrom.Close SaveChanges:=False
Exit Sub
End If
For Each wsCopyFrom In wbCopyFrom.Worksheets
If wsCopyFrom.Name <> "Set List" And wsCopyFrom.Name <> "Rarity Type Species List" And wsCopyFrom.Name <> "Need List" And wsCopyFrom.Name <> "Swap List" And wsCopyFrom.Name <> "Reference List" Then
Set wsCopyTo = wbCopyTo.Worksheets(wsCopyFrom.Name)
Set OutRng = UsedRangeUnlocked(wsCopyFrom)
If Not OutRng Is Nothing Then
For Each c In OutRng
If wsCopyTo.Range(c.Address).Locked = False Then
c.Copy wsCopyTo.Range(c.Address)
End If
Next c
End If
End If
Next wsCopyFrom
wbCopyFrom.Close SaveChanges:=False
Call CalcRefilter
Application.ScreenUpdating = True
MsgBox "The checklist was successfully imported from version " & OldVersion & " and updated to version " & NewVersion & "." & vbNewLine & vbNewLine & "Don't forget to save the new version."
End Sub
Function WorksheetExists(sName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
Function UsedRangeUnlocked(ws As Worksheet) As Range
Dim RngUL As Range, c As Range
For Each c In ws.UsedRange.Cells
If Not c.Locked Then
If RngUL Is Nothing Then
Set RngUL = c
Else
Set RngUL = Application.Union(RngUL, c)
End If
End If
Next c
Set UsedRangeUnlocked = RngUL
End Function
You can try to access the range. If it throws an error it does not exist:
Function RangeExists(RangeName As String) As Boolean
Dim rng As Range
On Error Resume Next
Set rng = Range(RangeName)
On Error GoTo 0 'needed to clear the error. Alternative Err.Clear
RangeExists = Not rng Is Nothing
End Function
Or to check at once if both exists (worksheet and range):
Function SheetAndRangeExists(WorksheetName As String, RangeName As String) As Boolean
Dim rng As Range
On Error Resume Next
Set rng = Worksheets(WorksheetName).Range(RangeName)
On Error GoTo 0
SheetAndRangeExists = Not rng Is Nothing
End Function
If you want to test it in a specific workbook:
Function SheetAndRangeExists(InWorkbook As Workbook, WorksheetName As String, RangeName As String) As Boolean
Dim rng As Range
On Error Resume Next
Set rng = InWorkbook.Worksheets(WorksheetName).Range(RangeName)
On Error GoTo 0
SheetAndRangeExists = Not rng Is Nothing
End Function
and call like SheetAndRangeExists(ThisWorkbook, "Main Page", "Version")
New to all this but appreciate any help I can get.
Problem: I have a duty roster with initials and sometimes I want to highlight a specific person to see his/her schedule. The highlight consists of changing the font color and making it bold but I'd also like the cell color to change as well, to lets say light green. I do know that I can use the Search/Replace feature but I'd like a macro for this.
So far, I've managed to piece together an input box and I can change the font color and add 'bold' to the font (and other changes) but I haven't solved changing the cell color.
This is what I have so far:
Sub FindAndBold()
Dim sFind As String
Dim rCell As Range
Dim rng As Range
Dim lCount As Long
Dim iLen As Integer
Dim iFind As Integer
Dim iStart As Integer
On Error Resume Next
Set rng = ActiveSheet.UsedRange. _
SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo ErrHandler
If rng Is Nothing Then
MsgBox "There are no cells with text"
GoTo ExitHandler
End If
sFind = InputBox( _
Prompt:="Skriv in dina initialer", _
Title:="Dina initialer")
If sFind = "" Then
MsgBox "Du skrev inget"
GoTo ExitHandler
End If
iLen = Len(sFind)
lCount = 0
For Each rCell In rng
With rCell
iFind = InStr(.Value, sFind)
Do While iFind > 0
.Characters(iFind, iLen).Font.Bold = True
.Characters(iFind, iLen).Font.Color = RGB(255, 0, 0)
.Characters(iFind, iLen).Font.ColorIndex = 4
lCount = lCount + 1
iStart = iFind + iLen
iFind = InStr(iStart, .Value, sFind)
Loop
End With
Next
If lCount = 0 Then
MsgBox "Fanns inget" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "att markera"
ElseIf lCount = 1 Then
MsgBox "Det fanns en" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "markerades"
Else
MsgBox lCount & " hittade" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "och markerades"
End If
ExitHandler:
Set rCell = Nothing
Set rng = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
Any help would be greatly appreciated!
(The text in the prompt and response is in Swedish)
You can also do this using conditional formatting, no need for VBS.
Using a conditional format formula you can enter something like this: =AND(ISNUMBER(SEARCH($G$1;A2));$G$1<>"") - in this case field G1 would be the field used for searching (read:highlighting) all the fields containing this condition.
If you desire a VBS we can improve and include a filter for all lines matching your search:
Sub searchfilter()
Range("A11:M10000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("A2:M13"), Unique:=False
End Sub
And to clear:
Sub clearfilter()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Assign both macros to a button.
Sample image where i combined both (filter was done on C15 in this case):
And sample with hidden fields shown:
I want to search text in shapes on Excel and I found the following code in excel.tips.net
Sub FindInShape1()
Dim rStart As Range
Dim shp As Shape
Dim sFind As String
Dim sTemp As String
Dim Response
sFind = InputBox("Search for?")
If Trim(sFind) = "" Then
MsgBox "Nothing entered"
Exit Sub
End If
Set rStart = ActiveCell
For Each shp In ActiveSheet.Shapes
sTemp = shp.TextFrame.Characters.Text
If InStr(LCase(sTemp), LCase(sFind)) <> 0 Then
shp.Select
Response = MsgBox( _
prompt:=shp.Name & vbCrLf & _
sTemp & vbCrLf & vbCrLf & _
"Do you want to continue?", _
Buttons:=vbYesNo, Title:="Continue?")
If Response <> vbYes Then
Set rStart = Nothing
Exit Sub
End If
End If
Next
MsgBox "No more found"
rStart.Select
Set rStart = Nothing
End Sub
It works if I search for a word that is in a shape near the top of the worksheet.
However, the worksheet is quite large, and if I search for something in the middle or bottom, I get error;
Run-time error '-2147024809 (80070057)': The specified Value is out of
range
I can choose to debug, and doing so highlights the line of code
sTemp = shp.TextFrame.Characters.Text
I'm using Excel 2010.
Thank you for your help,
Mattice
This is NOT an answer (but too much for a comment)
Please try this and check if the error still pops up:
Sub testForError()
Dim shp As Shape, i As Long
On Error Resume Next
For Each shp In ActiveSheet.Shapes
i = i + 1
Debug.Print i & " " & shp.Type
Debug.Print i & " " & shp.TextFrame.Characters.Text
Debug.Print i & " " & shp.TextFrame2.TextRange.Text
Next
Debug.Print "finished"
End Sub
EDIT
pls try it and tell me if errors pop up :)
Sub FindInShape1()
Dim shp As Shape
Dim sFind As String
Dim sTemp As String
sFind = InputBox("Search for?")
If Trim(sFind) = "" Then MsgBox "Nothing entered": Exit Sub
On Error Resume Next
For Each shp In ActiveSheet.Shapes
Debug.Print shp.TopLeftCell.Address
sTemp = ""
sTemp = shp.TextFrame.Characters.Text
If Len(sTemp) Then
If InStr(1, sTemp, sFind, 1) Then
shp.Select
If MsgBox(shp.Name & vbCrLf & sTemp & vbCrLf & vbCrLf & "Do you want to continue?", vbYesNo, "Continue?") <> vbYes Then Exit Sub
End If
End If
Next
MsgBox "No more found"
End Sub
You forget that you must put "set" before assigning any shape variable.
Set sTemp = shp.TextFrame.Characters.Text