When we open this workbook, this code will look through a range and find cells that contain the text "RCA Pending" and will popup a MsgBox letting the user know which row in that column contains the specific text. The problem is, if there are multiple rows containing this text, there will also be multiple MsgBox popups.
Private Sub Auto_Open()
Dim i As Variant
Dim FindRange As Range
Set FindRange = Range("AB2:AB2000")
For Each i In FindRange
If i = "RCA Pending" Then
MsgBox "Found 'RCA Pending' in cell" & " " & i.Address, vbExclamation, "Attention"
End If
Next i
End Sub
What needs to be changed in this code so that there is only one popup that lists all the rows where "RCA Pending" was found?
Try this code:
Private Sub Auto_Open()
Dim i As Variant
Dim FindRange As Range
Dim Msg As String
Set FindRange = Range("AB2:AB2000")
For Each i In FindRange
If i = "RCA Pending" Then
If Msg = "" Then
Msg = "Found 'RCA Pending' in cell" & " " & i.Address
Else
Msg = Msg & Chr(10) & "Found 'RCA Pending' in cell" & " " & i.Address
End If
End If
Next i
If Msg <> "" Then MsgBox Msg, vbExclamation, "Attention"
End Sub
Try this,
Sub Msgbox_It()
Dim sh As Worksheet
Dim LstRw As Long
Dim i As Range
Dim FindRange As Range
Dim Msg As String
Set sh = Sheets("Sheet1") 'name of worksheet
With sh
LstRw = .Cells(.Rows.Count, "AB").End(xlUp).Row
Set FindRange = .Range("AB2:AB" & LstRw)
For Each i In FindRange
If i = "RCA Pending" Then
Msg = Msg & i.Address & vbNewLine
End If
Next i
MsgBox "Found 'RCA Pending' in cell" & " " & Msg, vbExclamation, "Attention"
End With
End Sub
Related
This code is for something I'm doing at work, it's outputting "No patient reference!" in a MsgBox.
If I remove the if that checks if the cell is IsEmpty I get "Patient not found" in a MsgBox.
It seems like I'm missing something and I'm not sure what, can anyone help?
Private Sub CommandButton2_Click()
Dim emptytest2 As Boolean
emptytest2 = IsEmpty(Sheet1.Range("C28").Value)
If emptytest2 = False Then
MsgBox "No patient reference!"
End
End If
Dim found As Range
Dim band1 As Range
Dim foundoff As Range
Set found = Sheet2.Columns("B").Find(what:=Sheet1.Range("C28").Value, LookIn:=xlValues, lookat:=xlWhole)
If Not found Is Nothing Then
Set band1 = Sheet1.Range("C29")
MsgBox found & " - Data found for patient in cell " & found.Address
Set foundoff = Range(found.Address).Offset(, 30)
band1.Copy
Sheet2.Range(foundoff.Address).PasteSpecial
Else
MsgBox "Patient not found"
End
End If
MsgBox "Successfully added band cutoff data to " & found
End Sub
Option Explicit
Private Sub CommandButton2_Click()
Dim ref As Range, found As Range, rng As Range
Set ref = Sheet1.Range("C28")
If Len(ref.Value) = 0 Then
MsgBox "No patient reference!", vbExclamation
Exit Sub
End If
Set found = Sheet2.Columns("B:B").Find(what:=ref.Value, _
LookIn:=xlValues, lookat:=xlWhole)
If found Is Nothing Then
MsgBox "Patient Ref '" & ref.Value & "' not found", vbExclamation
Exit Sub
Else
Set rng = found.Offset(, 30) ' col AF
rng.Value = ref.Offset(1) ' C29
MsgBox "Patient Ref: '" & ref.Value & "' found in cell " & found.Address
End If
MsgBox "Successfully added " & rng.Value & " to " & rng.Address
End Sub
I have code to check empty cells in a range. I need those empty cell numbers to appear in a MsgBox.
Sub IsEmptyRange()
Dim cell As Range
Dim bIsEmpty As Boolean
bIsEmpty = False
For Each cell In Range("B1:B19")
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty = True Then
MsgBox "There are empty cells in your range"
'I NEED THE EMPTY CELLS TO APPEAR IN THE ABOVE MSGBOX
End If
End Sub
Just use:
msgbox Range("B1:B19").SpecialCells(xlCellTypeBlanks).Address
This solution adapts your code.
Dim cell As Range
Dim emptyStr As String
emptyStr = ""
For Each cell In Range("B1:B19")
If IsEmpty(cell) Then _
emptyStr = emptyStr & cell.Address(0, 0) & ", "
Next cell
If emptyStr <> "" Then MsgBox Left(emptyStr, Len(emptyStr) - 2)
If the cell is empty, it stores the address in emptyStr. The if condition can be condensed as isEmpty returns a Boolean.
Please try this code.
Sub ListEmptyCells()
Dim Rng As Range
Dim List As Variant
Dim Txt As String
Set Rng = Range("B1:B19")
On Error Resume Next
List = Rng.SpecialCells(xlCellTypeBlanks).Address(0, 0)
If Err Then
Txt = "There are no empty cells in" & vbCr & _
"the examined range."
Else
Txt = "The following cells are empty." & vbCr & _
Join(Split(List, ","), vbCr)
End If
MsgBox Txt, vbInformation, "Range " & Rng.Address(0, 0)
Err.Clear
End Sub
It uses Excel's own SpecialCells(xlCellTypeBlank), avoiding an error which must occur if this method returns nothing, and presenting the result in a legible format created by manipulating the range address if one is returned.
List blanks via dynamic arrays and spill range reference
Using the new dynamic array possibilities of Microsoft 365 (writing e.g. to target C1:C? in section b))
=$B$1:$B$19=""
and a so called â–ºspill range reference (as argument in the function Textjoin(), vers. 2019+ in section c))
C1# ' note the `#` suffix!
you could code as follows:
Sub TestSpillRange()
With Sheet1
'a) define range
Dim rng As Range
Set rng = .Range("B1:B19")
'b) check empty cell condition and enter boolean values into spill range C1#
.Range("C1").Formula2 = "=" & rng.Address & "="""""
'c) choose wanted values in spill range and connect them to result string
Dim msg As Variant
msg = Evaluate("TextJoin("","",true,if(C1#=true,""B""&row(C1#),""""))")
MsgBox msg, vbInformation, "Empty cells"
End With
End Sub
Find Blank Cells Using 'SpecialCells'
The 2nd Sub (listBlanks) is the main Sub.
The 1st Sub shows how to use the main Sub.
The 3rd Sub shows how SpecialCells works, which on one hand might be considered
unreliable or on the other hand could be used to one's advantage.
After using the 3rd Sub, one could conclude that SpecialCells 'considers' only cells at the intersection of the UsedRange and the 'supplied' range.
The Code
Option Explicit
Sub testListBlanks()
Const RangeAddress As String = "B1:B19"
Dim rng As Range: Set rng = Range(RangeAddress)
listBlanks rng
listBlanks rng, True
End Sub
Sub listBlanks(SourceRange As Range, _
Optional useList As Boolean = False)
Const proc As String = "'listBlanks'"
On Error GoTo clearError
Dim rng As Range: Set rng = SourceRange.SpecialCells(xlCellTypeBlanks)
Dim msgString As String
GoSub writeMsg
MsgBox msgString, vbInformation, "Blank Cells Found ('" & proc & "')"
Exit Sub
writeMsg:
msgString = "Blank Cells in Range '" & SourceRange.Address(False, False) _
& "'" & vbLf & vbLf & "The cells in range '" _
& rng.Address(False, False) & "' are blank."
If useList Then GoSub writeList
Return
writeList:
Dim cel As Range, i As Long, CellList As String
For Each cel In rng.Cells
CellList = CellList & vbLf & cel.Address(False, False)
Next cel
msgString = msgString & vbLf & vbLf _
& "The range contains the following " & rng.Cells.Count _
& " empty cells:" & vbLf & CellList
Return
clearError:
If Err.Number = 1004 And Err.Description = "No cells were found." Then
MsgBox "No blank cells in range '" & SourceRange.Address(False, False) _
& "' were found.", vbInformation, "No Blanks ('" & proc & "')"
Exit Sub
Else
MsgBox "An unexpected error occurred." & vbLf _
& "Run-time error '" & Err.Number & "': " & Err.Description, _
vbCritical, "Error in " & proc
End If
End Sub
Sub testUsedRangeAndSpecialCells()
Const wsName As String = "Sheet2"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
With ws
.Range("A:B").ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(1, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(2, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 3).Value = 3
Debug.Print .UsedRange.Address
.Cells(2, 3).ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 2).ClearContents
Debug.Print .Columns("B").SpecialCells(xlCellTypeBlanks).Address
Dim rng As Range: Set rng = .Columns("C")
Debug.Print rng.Address
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeBlanks)
If Err.Number <> 0 Then
MsgBox "We know that all cells are blank in range '" _
& rng.Address(False, False) & "', but 'SpecialCells' " _
& "doesn't consider them since they are not part of 'UsedRange'."
Debug.Print "No blank cells (not quite)"
Else
Debug.Print rng.Address
End If
On Error Goto 0
.Cells(3, 4).Value = 4
Set rng = rng.SpecialCells(xlCellTypeBlanks)
Debug.Print rng.Address(False, False)
End With
End Sub
The result of the 3rd Sub (testUsedRangeAndSpecialCells)
$A$1
$A$1
$A$1:$B$1
$A$1:$B$2
$A$1:$B$2
$A$1:$C$2
$A$1:$B$2
$B$1
$C:$C
No blank cells (not quite)
C1:C3
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
Please find the VBA code below:
Sub Select_File_Or_Files_Mac()
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim MySplit() As String
Dim a As String
Dim mybook As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastCell2 As Range
Dim cell As Variant
Dim Column As Integer
Dim rowno As Integer
On Error GoTo ErrHandler:
MyPath = MacScript("return (path to documents folder) as String")
'Or use MyPath = "Macintosh HD:Users:Ron:Desktop:TestFolder:"
' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & _
" {""org.openxmlformats.spreadsheetml.sheet.macroenabled""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
MyFiles = MacScript(MyScript)
MsgBox MyFiles
'On Error GoTo 0
MySplit = Split(MyFiles, ":")
MsgBox MySplit
'For N = LBound(MySplit) To UBound(MySplit)
a = MySplit(UBound(MySplit()))
MsgBox a
' Get the fi le name only and test to see if it is open.
'Fname = Right(MySplit(N), Len(MySplit(N)) - InStrRev(MySplit(N), Application.PathSeparator, , 1))
'If bIsBookOpen(Fname) = False Then
'MsgBox MySplit
'Set mybook = Nothing
'On Error Resume Next
Set mybook = Workbooks.Open(a)
Set ws1 = ThisWorkbook.Worksheets("User_Financial_Input")
Set ws2 = mybook.Worksheets("User_Financial_Input")
ws2.Activate
With ws2
Set LastCell2 = ws2.Range("InputCells_User_Financial_Input")
MsgBox LastCell2
End With
ws2.Select
ws1.Activate
For Each cell In LastCell2
Column = cell.Column
rowno = cell.Row
ws1.Cells(rowno, Column) = cell.value
Next
ErrHandler:
If Err.Number = 9 Then
Answer = MsgBox(Err.Description & Err.Number, vbCritical, "Error")
ElseIf Err.Number = 1004 Then
Answer = MsgBox(Err.Description & Err.Number, vbCritical, "Error")
ElseIf Err.Number = 0 Then
Else
Answer = MsgBox(Err.Description & Err.Number, vbCritical, "Error")
End If
End Sub
There is some problem in the line Set mybook = Workbooks.Open(a). I am getting "Type 13" mismatch error.
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