My code below works perfectly to find a cell on a different worksheet when the string is small, however large text strings pull up an error. I have tried using error handling even just to give a MsgBox rather than open a VBA window when it errors.
Can anyone help, preferably find the cell with many characters or if not possible, put an error handler in to say something like, too large to search.
What the code does, is a have a range of cells with text in each cell. I can click on that cell, or a cell 2 columns to the right, then click the FIND button, to go in the next worksheet to find the exact same cell value. All cells are unique.
Sub Find_Cell()
Dim NA As Worksheet
Set NA = Worksheets("Notes Analysis")
LastRow = NA.Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
If Not Intersect(ActiveCell, Range("G19:G" & LastRow)) Is Nothing Then
Dim value As String 'Declare a string
value = ActiveCell.Offset(, -2) 'Get the value of the selected Cell
Dim ws As Worksheet
'ws is the worksheet from we are searching the value
'You have to change myWorkSheetName for you worksheet name
Set ws = ThisWorkbook.Worksheets("DEBT_SALE_ACTIVITY")
ws.Activate
Dim c As Range 'Declare a cell
Set c = ws.Cells.Find(value, LookIn:=xlValues) 'Search the value
If Not c Is Nothing Then 'If value found
c.Activate 'Activate the cell, select it
Else
MsgBox "Not found" 'shows a message "Not Found"
End If
Else
If Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
Dim value2 As String 'Declare a string
value2 = ActiveCell 'Get the value of the selected Cell
Dim ws2 As Worksheet
'ws is the worksheet from we are searching the value
'You have to change myWorkSheetName for you worksheet name
Set ws2 = ThisWorkbook.Worksheets("DEBT_SALE_ACTIVITY")
ws2.Activate
Dim c2 As Range 'Declare a cell
Set c2 = ws2.Cells.Find(value2, LookIn:=xlValues) 'Search the value
If Not c2 Is Nothing Then 'If value found
c2.Activate 'Activate the cell, select it
Else
MsgBox "Not found" 'shows a message "Not Found"
End If
Else
MsgBox "Select an Account Note"
End If 'end the If for if active cell is in our notes
End If 'end the If for if active cell is in Account note
End Sub
To provide an error message indicating the text is too long you could do the following:
Add this after each statement where you assign value its value:
value = ActiveCell.Offset(, -2) 'Get the value of the selected Cell
If Len(value) > 255 Then
MsgBox "Text in cell " & CStr(ActiveCell.Address) & " is too long", vbOKOnly, "Search Text Too Long"
Exit Sub
End If
Also, you might want to change your if...then...else code structure.
Currently your code is operating like this:
If Not Intersect(ActiveCell, Range("G19:G" & LastRow)) Is Nothing Then
do things
exit sub
Else
If Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
do things
exit sub
Else
MsgBox "Select an Account Note"
exit sub
Which, based on your comments for your End If's isn't exactly what your message box says. If your first if statement is Account Notes and your second if statement is notes, then a better structure would be the following.
Change this code
Else
If Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
To look like this
ElseIf Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
Then the statement `MsgBox "Select an Account Note" will be accurate. You also be able to delete one of your End If statements.
Your code will operate like this:
If Not Intersect(ActiveCell, Range("G19:G" & LastRow)) Is Nothing Then
do things
exit sub
ElseIf Not Intersect(ActiveCell, Range("E19:E" & LastRow)) Is Nothing Then
do things
exit sub
Else
MsgBox "Select an Account Note"
exit sub
Related
I am trying to write a macro on a password protected sheet that will allow users to delete a specific row but only if the cell in column BR does not contain the word "keep" and if they choose a row that cannot be deleted an error message will pop up stating "You have chosen a row that cannot be deleted. Please choose another row".
I have worked out the first part (below) but don't know how to tell it to only delete the row if the word "keep" is not in column BR. I am very new to VBA and muddling along via google but I am officially stuck.
Dim x As Integer
On Error Resume Next
ActiveSheet.Unprotect Password:="password"
x = InputBox("Please Enter the Row Number")
Range("A" & x).EntireRow.Delete Shift:=xlUp
ActiveSheet.Protect Password:="password"
End Sub
This should do:
Sub not_mentioned()
Dim x As Long
ActiveSheet.Unprotect Password:="password"
x = InputBox("Please Enter the Row Number")
If Not UCase(Cells(x, 70)) Like "*KEEP*" Then
Range("A" & x).EntireRow.Delete Shift:=xlUp
Else
MsgBox "You have chosen a row that cannot be deleted." & Chr(10) & "Please choose another row"
End If
ActiveSheet.Protect Password:="password"
End Sub
Here is a method asking the user to select a cell on the row to delete with Application.InputBox.
Option Compare text makes this non-case-sensitive. I.E. KEEP = keep. It's also unclear if the cell will have Keep mixed in with a string, or will just contain the word Keep. Either way, looks like you have a solution to cover both!
Option Explicit
Option Compare Text
Sub DeleteMe()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim TargetRow As Range
On Error Resume Next 'If user hits "Cancel" on Input Box
Set TargetRow = Application.InputBox("Please Select a Cell on Row to Delete", Type:=8)
On Error GoTo 0
If Not TargetRow Is Nothing Then
If ws.Cells(TargetRow.Row, "BR") = "keep" Then
MsgBox "You have chosen a row that cannot be deleted. Please choose another row", vbCritical
Else
ws.Unprotect "password"
ws.Cells(TargetRow.Row, 1).EntireRow.Delete
ws.Protect "password"
End If
End If
End Sub
My problem is that I need to execute a Macro only on the marked cell.
The Macro needs to do the following:
Selected cell is formated always for example as 20*20*20 always 3 numbers.
It should copy this text add a " = " before the numbers and output it on another column.
The Code I got until now is:
Sub First()
'
' First Makro
'
'
Selection.Copy
Range("G11").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=20*20*20"
Range("G12").Select
End Sub
I have got this code with the record Macro function
Thanks very much
#SiddharthRout exactly but i need to be able to select it by hand because sometimes it's for example E17 sometimes e33 and output always need's to be G Column in the Same Row
Is this what you are trying?
Sub Sample()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
'~~> Replace Sheet1 with the relevant sheet name
Set ws = wb.Sheets("Sheet1")
'~~> Check if what the user selected is a valid range
If TypeName(Selection) <> "Range" Then
MsgBox "Select a range first."
Exit Sub
End If
'~~> Check if the user has selected a single cell
If Selection.Cells.Count > 1 Then
MsgBox "Please select a single cell"
Exit Sub
End If
ws.Range("G" & Selection.Row).Formula = "=" & Selection.Value
End Sub
I have this code which allows to a copy a customized range from any sheet and paste it to a fixed range on sheet 2. This code works but I need to implement paste link function in this code, so that if i want to make any changes to the data in DB it will auto update in sheet 2 as well. Here is the code I have done so far. Thank you in advance
Sub CustomizedInputFixedoutput()
Dim rng As Range, _
inp As Range, _
ws As Worksheet
Set inp = Selection
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled", vbInformation
Exit Sub
Else
rng.Parent.Activate
rng.Copy
Sheets("Sheet 2").Range("B2:N5").Value = rng.Value
End If
Application.CutCopyMode = False
End Sub
I felt sure this had to be a duplicate but searching [excel-vba] Paste Link found a few questions without any accepted answers and none that matched to OP desire to paste into a specific range.
Option Explicit
Sub CustomizedInputFixedoutput()
Dim CopyRng As Range
Dim PasteRng As Range
Dim Msg As String
Dim Response As VbMsgBoxResult
Set CopyRng = Selection
On Error Resume Next
Set PasteRng = Application.InputBox("Select a cell to copy to", Type:=8)
On Error GoTo 0
If Not PasteRng Is Nothing Then 'user clicked Cancel
If PasteRng.Count > 1 Then
'Get confirmation to paste to multi-cell range
Msg = "Are you sure you want to paste to " & PasteRng.Address & "?" _
& vbCrLf & vbCrLf _
& "Results may be unexpected if you proceed."
Response = MsgBox(Msg, vbQuestion + vbYesNo, "Confirm multi-cell paste range")
End If
If Response = vbYes Or PasteRng.Count = 1 Then
CopyRng.Copy
PasteRng.Parent.Activate
PasteRng.Activate
ActiveSheet.Paste Link:=True
Else
MsgBox "Cancelled", vbInformation
End If
Else
MsgBox "Cancelled", vbInformation
End If
Application.CutCopyMode = False
End Sub
Here you copy the range:
rng.Copy
And here you are assigning the value of B2:N5 the same value as rng.
Sheets("Sheet 2").Range("B2:N5").Value = rng.Value
The problem is that that code isn't pasting anything from the clipboard! You don't need to .Copy anything to assign cell values like this.
Use the Worksheet.Paste method instead of assigning the values (then the .Copy will serve its purpose), and set the optional parameter Links to True, like this:
Worksheets("Sheet 2").Range("B2:N5").Select
Worksheets("Sheet 2").Paste Links:=True
The Data
Sheet one will be for data entry. Each row will represent a Service Ticket. Each column will represent data about the service incident such as serial number or model number.
Desired Result
For each row containing data in a particular field (Column A ~ "Ticket Number) Excel will create a new sheet (The service ticket) based on a template and place the data from the corresponding row into the designated cells.
Thank you in advance for any assistance you may be able to provide.
I'll start by saying that you should be careful with this as there is a limit to the number of sheets in a workbook. But here is some code in vb. It should give you the logic to get it done in vba. There will just be some difference in referring to the sheet and maybe cells.
You will need to declare the worksheet that you are reading through
Dim ws As Excel.Worksheet
Set ws = ea.Worksheets(1)
It may start at sheet index 0 so Set ws = ea.Worksheets(0)
Or there is something like Excel.Application.Activsheet
Here is the logic to loop through the rows and check the value of column A.
dim lRow as integer
Do While lRow <= ws.UsedRange.Rows.Count
If ws.Range("A" & lRow).Value <> "" Then Then
'If cell A is not blank we then call the worksheet add function.
'Pass the name you want the worksheet and the page setup arguments.
WorksheetAdd ws.Range("A" & lRow).Value, xlPaperLetter, xlPortrait
ws.name = ws.Range("A" & lRow).Value
End If
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
You will want a worksheetAdd function like this
Private Sub WorksheetAdd(szJobNumber As String, Papersize As XlPaperSize, PageOrientation As XlPageOrientation)
Dim bDisplayAlerts As Boolean
On Error GoTo ErrorHandler
'Add worksheet to workbook.
Set ws = ea.Worksheets.Add
ws.Name = szJobNumber
With ws.PageSetup
.Orientation = PageOrientation
.LeftFooter = "&D"
.CenterFooter = "&A"
.RightFooter = "Page &P of &N"
.Papersize = Papersize
End With
On Error GoTo 0
Exit Sub
ErrorHandler:
If Err.Number = 1004 Then
If MsgBox("There has been an error(#1004). Contact support. Excel is not installed or produced an error. Also, check for default printer.",vbCritical, "Information") = vbOK Then
'Unload frmPTReports
Exit Sub
End If
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Sub
Given two cells with contents '=Foo and =Foo, getting the properties .Value,.Value2, .Text, .Formula all give me =Foo for both ranges.
How do I include the escaping apostrophe so that I get '=Foo when returning the cell value?
Use .PrefixCharacter to get the hidden apostrophe.
Like this: Debug.Print Range("A1").PrefixCharacter
Depending on what your trying to do with it, this Microsoft Post might be helpful.
Full Example:
Sub test()
Dim wks As Worksheet
Set wks = Worksheets("Sheet1")
Dim rng As Range
Set rng = wks.Range("A1")
If Not rng.HasFormula Then
If rng.PrefixCharacter <> "" Then
MsgBox "Cell value is: " & rng.PrefixCharacter & rng.Text
Else
MsgBox "No prefix value in cell " & rng.Address
End If
End If
End Sub