I have a code which deletes a value from a locked sheet. Whenever I run the code, Error message
Delete method of Range class failed
is displayed. How do I prompt the user with a message such as first unprotect the sheet?
Sub DeleteRow()
Dim rng As Range
On Error Resume Next
With Selection.Cells(1)
Set rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Please select a valid table cell.", vbCritical
Else
rng.delete xlShiftUp
End If
End With
End Sub
This will Work:
Activesheet.ProtectContents will tell you if a sheet is protected or not.
Sub DeleteRow()
Dim rng As Range
On Error Resume Next
If ActiveSheet.ProtectContents = False Then
With Selection.Cells(1)
Set rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Please select a valid table cell.", vbCritical
Else
rng.Delete xlShiftUp
End If
End With
Else: MsgBox "Unprotect the Sheet First!"
End If
End Sub
Related
so i used this code
Set Rng = Sheets("COA").Range("i11:i39")
On Error Resume Next
Set VisibleCells = Rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not VisibleCells Is Nothing Then
For Each aCell In VisibleCells
Select Case aCell.DisplayFormat.Interior.Color
Case vbRed
MsgBox "Terdapat data outspek. Periksa kembali!", vbCritical + vbOKOnly, ""
'Show Excel and resize the UserForm2
Application.Visible = True
Me.Height = 405
Me.Width = 730.5
SaveButton.Enabled = False
Case 16777215
Unload UserForm2
'Gets the name of the currently visible worksheet
Filename = "COA" & Sheets("COA").Range("B1")
'Puts the worksheet into its own workbook
ThisWorkbook.ActiveSheet.Copy
'Saves the workbook
ActiveWorkbook.SaveAs Filename
'Closes the newly created workbook so you are still looking at the original workbook
ActiveWorkbook.Close
End Select
Next aCell
End If
If there is a red cell then it will return to the userform. cell I17 is not red, but why is it automatically saved in .xls format? even though if there is a red cell, it cannot be saved in .xls format and must return to the userform. can you guys help me?
Suggest something like this:
Option Explicit
Sub Tester()
Dim rng As Range, Filename As String
Set rng = ThisWorkbook.Sheets("COA").Range("I11:I39")
If HasVisibleRedCell(rng) Then 'call the function to check the range...
MsgBox "Terdapat data outspek. Periksa kembali!", vbCritical + vbOKOnly, ""
Application.Visible = True
Me.Height = 405
Me.Width = 730.5
Me.SaveButton.Enabled = False
Else
Unload UserForm2 'Me?
Filename = "COA" & ThisWorkbook.Sheets("COA").Range("B1")
ThisWorkbook.ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename '<<< should use a full path here...
ActiveWorkbook.Close False
End If
End Sub
'Does the range `rng` contain at least one visible red-filled cell?
Function HasVisibleRedCell(rng As Range) As Boolean
Dim VisibleCells As Range, c As Range
On Error Resume Next
Set VisibleCells = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not VisibleCells Is Nothing Then 'any visible cells?
For Each c In VisibleCells 'check each cell fill
If c.DisplayFormat.Interior.Color = vbRed Then
HasVisibleRedCell = True 'found one
Exit Function 'no need to check further
End If
Next c
End If
'if got here then by default returns False...
End Function
I want to check if specific range (L32,M32;N32;O32;P32;Q32,R32;S32;T32).
If one of the cells is not empty a message should be displayed "FSFV check".
For Each cell In Range("L32:T32")
If cell.Value <> "" Then
MsgBox "Check with CRA if FSFV was performed and notify RA"
Else
End If
Next
End Sub
It displays the message eight times but I only want it once.
How about :
Sub Test()
Dim AnyData As Integer
AnyData = WorksheetFunction.CountA(Range("L32:T32"))
If AnyData = 0 Then
Exit Sub
Else
MsgBox "Check with CRA if FSFV was performed and notify RA"
End If
End Sub
If a Cell in a Range Is Blank...
If you're practicing loops, you could do the following.
Sub Test1()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim cell As Range
For Each cell In ws.Range("L32:T32").Cells
If Len(CStr(cell.Value)) = 0 Then ' cell is blank
MsgBox "Check with CRA if FSFV was performed and notify RA", _
vbExclamation
Exit For ' blank cell found, stop looping
' Or:
'Exit Sub ' blank cell found, stop looping
End If
Next cell
' With 'Exit For' you'll end up here
' and you could continue with the sub.
End Sub
If not, rather use the following.
Sub Test2()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If Application.CountBlank(ws.Range("L32:T32")) > 0 Then
MsgBox "Check with CRA if FSFV was performed and notify RA", _
vbExclamation
End If
End Sub
Hardly Related But Interesting
If you were wondering what happens to an object-type Control variable (in this case cell) in a For Each...Next loop when the loop has finished uninterrupted, the following example proves that it is set to Nothing.
Sub Test3()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim cell As Range
For Each cell In ws.Range("L32:T32").Cells
If Len(CStr(cell.Value)) = 0 Then Exit For
Next cell
If Not cell Is Nothing Then
MsgBox "Check with CRA if FSFV was performed and notify RA", _
vbExclamation
Exit Sub
End If
MsgBox "Continuing...", vbInformation
End Sub
Let me give you the simplest approach:
Dim Found As Boolean
Found = False
For Each cell In Range("L32:T32")
If cell.Value <> "" Then
Found = True
End If
Next
If Found Then
MsgBox "Check with CRA if FSFV was performed and notify RA"
End If
As you see, the fact that you have found an empty cell is kept in a Boolean variable, and afterwards you just use that information for showing your messagebox.
I have a code to filter data and copy to new worksheet. I have an issue where if the sheet being created already exists then it will jump to error handling and stop not continue with remaining 'next'. If i move the 'Next' after the error handling it will only loop if there is and error. Is there a way I can have both?
Sub SortDataAll()
' Sort Data All
If (Workbooks("Fakturagrunnlag All_1.xlsm").Sheets("All Focal Point Data").AutoFilterMode And Workbooks("Fakturagrunnlag All_1.xlsm").Sheets("All Focal Point Data").FilterMode) _
Or Workbooks("Fakturagrunnlag All_1.xlsm").Sheets("All Focal Point Data").FilterMode Then
Workbooks("Fakturagrunnlag All_1.xlsm").Sheets("All Focal Point Data").ShowAllData
End If
'~~> Set filter of main data
Dim rRange As Range
Dim rCell As Range
Set rRange = Worksheets("Front Page").Range("A7:A21")
For Each rCell In rRange
MsgBox "Setting filter for " & rCell
Dim rList As String
rList = rCell & "List"
MsgBox "The list for filter is" & rList
' can remove after
Worksheets("All Focal Point Data").Activate
Dim v As Variant
v = Application.WorksheetFunction.Transpose(Range(rList).Value)
Range("A:BC").AutoFilter Field:=54, Criteria1:=v, Operator:=xlFilterValues
Selection.AutoFilter Field:=54, Criteria1:=v, Operator:=xlFilterValues
MsgBox "Check data is filtered"
'~~> Create new sheet and paste data
On Error Resume Next
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = rCell
End With
If Err Then GoTo ErrorJump
Err.clear
Worksheets("All Focal Point Data").Range("A1:BC5000").Copy Worksheets(rCell).Range("A1").Paste
Columns("BB:BB").Delete Shift:=xlToLeft
Next rCell
Exit Sub
ErrorJump:
MsgBox "Sheet already exists":
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'Worksheets("Front Page").Activate
'Range("A1").Select
Next rCell
End Sub
I've used a method where you simply try to use the worksheet and let error control create the worksheet if an error is thrown.
In this, if the abc worksheet exists, it is used. If it doesn't exist, it is created then used.
sub testws()
dim wsn as string
wsn = "abc"
on error goto make_ws
with worksheets(wsn)
on error goto 0
...
end with
exit sub
make_ws:
with worksheets.add
.name = wsn
end with
resume
end sub
I'm working with a sub which calls an input box to copy selected cells from a sheet and paste them into a multicolumn listbox. I've finally got everything working correctly, except the error 424 when the user cancels the inputbox. I've read through countless help threads regarding this error and have found nothing that seems to be able to handle the error for me. I'm hoping that someone out there can tell me if something is wrong with the code below (aside from 12 million exit sub attempts to stop the error), or possibly give me an idea of another area (Declarations, Initialization, Activate?) that I should be checking. Any ideas are appreciated, thanks.
Private Sub CopyItemsBtn_Click()
Dim x As Integer
Dim rSelected As Range, c As Range
Dim wb
Dim lrows As Long, lcols As Long
x = ProformaToolForm.ItemsLB.ListCount
'Prompt user to select cells for formula
On Error GoTo cleanup
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
If Err.Number = 424 Then
Debug.Print "Canceled"
Exit Sub
ElseIf Err.Number <> 0 Then
Debug.Print "unexpected error"
Exit Sub
End If
If rSelected.Rows.Count < 1 Or rSelected.Columns.Count < 1 Then
Exit Sub
End If
Err.Clear
On Error GoTo 0
'Only run if cells were selected and cancel button was not pressed
If Not rSelected Is Nothing Then
For Each c In rSelected
With ProformaToolForm.ItemsLB
.AddItem
.List = rSelected.Cells.Value
End With
Next
Else
Exit Sub
End If
cleanup: Exit Sub
End Sub
After some cleanup, here's my attempt with Tim's code:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range, c As Range
Dim wb
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
'Prompt user to select cells for formula
On Error Resume Next
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
On Error GoTo 0
If rSelected Is Nothing Then
MsgBox "no range selected", vbCritical
Exit Sub
End If
For Each c In rSelected
With ProformaToolForm.ItemsLB
.AddItem
.List = rSelected.Cells.Value
End With
Next
End Sub
Here's how I'd tend to do this:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range
On Error Resume Next
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
On Error GoTo 0
If rSelected Is Nothing Then
MsgBox "no range selected!", vbCritical
Exit Sub
End If
'continue with rSelected
End Sub
Found a solution, from Dirk's final post here. For anyone interested, here is the working code:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range
Dim wb
Dim MyCol As New Collection
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
MyCol.Add Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
If TypeOf MyCol(1) Is Range Then Set MyRange = MyCol(1)
Set MyCol = New Collection
If rSelected Is Nothing Then
MsgBox "no range selected", vbCritical
Exit Sub
End If
ProformaToolForm.ItemsLB.List = rSelected.Value
End Sub
I'm trying to replace ctrl+c so it will copy only visible cells on a protected sheet. Trying to solve this problem I stumbled on this post (vba excel copy only visible cells on key press ctrl+c)
The following code (suggested by Siddharth-Rout) works but only for a non-protected sheet:
Private Sub Workbook_Open()
Application.OnKey "^c", "Copy"
End Sub
Sub Copy()
Dim rng As Range
On Error GoTo Whoa
If Not Selection Is Nothing Then
Set rng = Selection.Cells.SpecialCells(xlCellTypeVisible)
rng.Copy
End If
LetsContinue:
Exit Sub
Whoa:
MsgBox Err.Description, vbCritical, "Error Number : " & Err.Number
Resume LetsContinue
End Sub
I tried unprotecting, copying, and then reprotecting but it removes the copy. I need the final sheet to be protected. Any help would be appreciated.
Ah! A blast from the past :P
You need to unprotect and protect just before you copy. Also I am using ActiveSheet for demonstration purpose. Change that to the relevant sheet if required.
Is this what you are trying?
Sub Copy()
Dim rng As Range
Dim MyPassword As String
'~~> Change password as applicable
MyPassword = "Sid"
On Error GoTo Whoa
If Not Selection Is Nothing Then
ActiveSheet.Unprotect MyPassword
Set rng = Selection.Cells.SpecialCells(xlCellTypeVisible)
ActiveSheet.Protect MyPassword
rng.Copy
End If
LetsContinue:
Exit Sub
Whoa:
MsgBox Err.Description, vbCritical, "Error Number : " & Err.Number
Resume LetsContinue
End Sub