I have a short code that basically copies a selected row to another sheet, and deletes it from the first.
For some reason when I run this, it will run just fine, if I then select a different row, I get a pasteSpecial method of RangeClass failed error.
Sub Completed()
Dim trackerRow As Integer, compRow As Integer, answer As Integer
Application.ScreenUpdating = False
Application.CutCopyMode = False
trackerRow = ActiveCell.Row
compRow = Sheets("Completed").Cells(Rows.Count, "B").End(xlUp).Row
If trackerRow < 3 Then Exit Sub
If Cells(trackerRow, 2) = "" Then
MsgBox "This row is empty, please select the candidate you want to move.", vbExclamation, "Empty Row"
Else
answer = MsgBox("Are you sure you want to move " & Cells(trackerRow, 3).Value & "?", vbYesNo, "Confirm move?")
If answer = vbYes Then
'move row
Rows(trackerRow).EntireRow.Copy
With ThisWorkbook
With .Sheets("Completed")
.Activate
.Unprotect "HSBC2017"
.Cells(compRow + 1, 1).PasteSpecial xlPasteValues '**error line**.
.Protect "HSBC2017"
End With
With .Sheets("Tracker")
.Unprotect "HSBC2017"
.Rows(trackerRow).EntireRow.Delete
.Protect "HSBC2017"
.Activate
End With
End With
End If
End If
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
I can't work out why when I open the document it will work once, but you have to re-open to run a second time?
Each time you crash into a debug, you leave the destination Completed worksheet unprotected. Closing the workbook and reopening it leaves it unprotected.
Unprotecting an unprotected worksheet does not cancel the .CutCopyMode but unprotecting a protected worksheet does.
So in the first run-through with an unprotected destination worksheet there is something on the clipboard (and you have 'dancing ants' on the row-to-copy on the Tracker worksheet). Since everything runs through, the destination Completed worksheet is now protected and a second run-through will cancel the .CutCopyMode when the worksheet is unprotected. You can watch this by stepping through your code with F8 and see the 'dancing ants' disappear from the copy area on the Tracker worksheet as soon as you unprotect the Completed worksheet a second time.
Possible solutions (with a nod to comments from Peh and Rory):
Protect the worksheet with a password and UserInterfaceOnly.
with worksheets("Completed")
.Protect Password:="HSBC2017", UserInterfaceOnly:=True
end with
This only has to be done once and you can remove both the .Unprotect and .Protect code from future sub procedure operations. Only actions made manually by the user will be restricted.
Initiate the copy from the source worksheet after unprotecting the destination worksheet.
with worksheets("Completed")
.Unprotect Password:="HSBC2017"
worksheets("Tracker").Rows(trackerRow).EntireRow.Copy
.Cells(compRow + 1, 1).PasteSpecial xlPasteValues
.Protect Password:="HSBC2017"
end with
Related
I have a log of incoming / outgoing test samples which I've added code to kick users out if no worksheet change is detected for more than 5 minutes (https://excelribbon.tips.net/T008192_Forcing_a_Workbook_to_Close_after_Inactivity.html). In order to make sure users have macros enabled, I have a worksheet called "Splash Screen" which is the only worksheet visible when the workbook is first opened (all other worksheets are set to xlVeryHidden).
The code I have to hide/unhide worksheets looks simple and works perfectly if the workbook is closed manually, but not if forced to close via the timeout. This is called near the end of the Workbook_BeforeClose procedure:
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case Is = "Splash Screen"
ws.Visible = xlSheetVisible
Case Else
ws.Visible = xlSheetVeryHidden
End Select
Next
Application.ScreenUpdating = True
After this code block has run, there is no change to the visibility of the worksheets. Everything which was hidden is still hidden, everything that was visible is still visible, everything that was veryhidden is still veryhidden.
The worksheets are locked, but I've tried unlocking them before hiding them and that doesn't help. I've ensured events are enabled, screenupdating is true, errors are not set to "Resume Next", but none of it seems to help. Any suggestions?
Edited to add more code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Checks for missing data in rows to be locked - if missing, user is prompted to enter
'User can optionally cancel closing the document to enter missing data
Call DataMissing(Cancel) 'If data missing and user wishes to enter, Cancel = True
If Cancel Then Exit Sub 'If Cancel = True, exit without further action
'Locks rows which were changed and Logs changes (if any were made)
Call LockRows
Call EmailPM("Delivered")
Call Internal_LockRows
If Not Not LoggedRows Then
Call LogChanges
Call EmailPM("Edited")
End If
If Not Not Internal_LoggedRows Then
Call Internal_LogChanges
End If
Call EmailPM("Internal")
'If changes have been made to live samples, updates lab manager
If Not Not LiveRows Then Call EmailPM("Live")
If Not Not Internal_LiveRows Then Call EmailPM("Internal_Live")
'Clears all filters on all sheets
Dim ws As Worksheet
On Error Resume Next
For Each ws In ThisWorkbook.Worksheets
ws.AutoFilter.ShowAllData
Next ws
On Error GoTo 0
'Selects MainLab sheet before closing
MainLab.Select
'Ensures TimeStop and RowID will fire on worksheet change
Application.EnableEvents = True
Call TimeStop
'Hides sheets (only unhides if macros are enabled)
Call HideSheets
'Stores who closed the file to log
LogToFile (ThisWorkbook.Name & "; " & OpenState & "; closed by; " & Environ("Username") & "; " & Format(Now, "yyyy-mm-dd hh:mm:ss"))
End Sub
Sub TimeSetting()
'Sets CloseTime to a set time in the future, then runs SavedAndClose
CloseTime = Now + TimeValue("00:00:30") 'Timeout after 5 mins of inactivity
On Error Resume Next
Application.OnTime earliesttime:=CloseTime, procedure:="SavedAndClose", Schedule:=True
On Error GoTo 0
End Sub
Sub TimeStop()
'A sub to stop the timer ticking down
On Error Resume Next
Application.OnTime earliesttime:=CloseTime, procedure:="SavedAndClose", Schedule:=False
On Error GoTo 0
End Sub
Sub SavedAndClose()
'Closes the workbook and saves when called
Application.CutCopyMode = False 'Empties the clipboard to avoid the potential "keep the clipboard" alert
LogToFile (ThisWorkbook.Name & "; " & OpenState & "; auto-closed; " & Environ("Username") & "; " & Format(Now, "yyyy-mm-dd hh:mm:ss"))
ThisWorkbook.Close savechanges:=True
End Sub
The main reason this does not work is ThisWorkbook.saved = True. Essentially this is saying I've already saved so don't bother prompting me to save when I close. Problem is you haven't saved at the time you are calling close.
Here is a basic example of the setup. You want to: 1. Hide the sheets, 2. Save the document, 3. Close.
Sub HideSheets()
' Insert your hide sheet code here
Sheet2.Visible = xlSheetHidden ' Test line to hide one sheet
ThisWorkbook.Save
End Sub
Sub ShutDown()
Call HideSheets
ThisWorkbook.Close
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'This doesn't do much on the automated close, because you've saved already.
Call HideSheets
End Sub
Sub addinfo()
If Range("FH17") = "Unlocked" Then
Result = MsgBox("Are you sure you want to add information for a new year? (This is only to be done after you have created a new workbook for a new year)", vbYesNo + vbQuestion)
If Result = vbYes Then
Range("FH17").Value = "Locked"
'creating template
Set wk = ThisWorkbook
Dim template As String
template = Sheets("Data").Range("EW12").Value
'add template
wk.Sheets("Data").Range("A1:BC1000").Copy wk.Sheets(template).Range("A1")
'add old info
wk.Sheets("Data").Range("IE5:IK1000").Copy wk.Sheets(template).Range("A5")
wk.Sheets("Data").Range("IL5:IM1000").Copy wk.Sheets(template).Range("J5")
wk.Sheets("Data").Range("IN5:IW1000").Copy wk.Sheets(template).Range("O5")
'change date
wk.Sheets("Data").Range("EX12").Copy wk.Sheets(template).Range("E1")
'copy format to template
wk.Sheets("Data").Range("A:BC").Copy
wk.Sheets(template).Range("A1").Parent.Activate
wk.Sheets(template).Range("A1").PasteSpecial xlPasteColumnWidths
wk.Sheets(template).Range("A1").PasteSpecial xlPasteFormats
Application.CutCopyMode = False
'unhide columns
wk.Sheets(template).Range("A:BC").Select
Selection.EntireColumn.Hidden = False
'Hide columns
wk.Sheets(template).Range("AC:AD").Select
Selection.EntireColumn.Hidden = True
wk.Sheets(template).Range("AM:AN").Select
Selection.EntireColumn.Hidden = True
wk.Sheets(template).Range("AR:AT").Select
Selection.EntireColumn.Hidden = True
wk.Sheets(template).Range("A1").Select
Call rows_freeze
'Protect the sheet
ActiveSheet.Protect
MsgBox "Done."
Else
Range("FH17").Value = "Locked"
End If
End If
End Sub
This is my code, it works fine. except the part of calling on "row_freeze". I tried not having it as 2 macros but that didnt work either. I get a 400 error message. Anyone with any idea? The only part that actually needs to be fixed is the code below, I'm trying to autofit row 3 and then freeze everything above cell A4. (I tried to skip the "Rows("3:3").Select" and that did nothing)(the code works if I do it in a an new empty workbook)
Sub rows_freeze()
Rows("3:3").Select
Rows("3:3").EntireRow.AutoFit
Range("A4").Select
ActiveWindow.FreezePanes = True
End Sub
EDIT:
I format the width of the columns, I believe that it sometimes "has time" to make the columns big enough for the text to fit. but sometimes it does not and the "wrap text" causes the rows to get very long(height). I removed both lines of code(rows and freeze) and I dont get any error message (this time the rows actually did not need to be autofitted, but sometimes they do).
EDIT 2:
'copy sheet to new workbook
sheettocopy = Range("EW10").Value
Worksheets(sheettocopy).Copy
Dim wb As Workbook
'Store new workbook into a variable
Set wb = ActiveWorkbook
'Fix any macro assigned buttons
Call FixMacroLinks(wb)
'adding sheet and renaming
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = Sheets("Data").Range("EW12").Value
ActiveWorkbook.Sheets("Data").Activate
MsgBox "Done."
Else
MsgBox "You do not have a december month"
Range("FF17").Value = "Locked"
This is the code when creating the new workbook. The first thing I do when this is done, is to start the "Addinfo" sub
I have not worked with your sheet before, but I found that I was having the same problem of a 400 error while trying to autofit columns. I was able to resolve the issue when I put my code for autofitting my columns before my code for protecting my cells.
Following on from a previous question I asked today - I have modified code written by Roy Cox (Thank you for saving me SO much time!) to create a userform to add, modify and delete users' details in an analysis tool I am creating.
It works perfectly when working with user data on a single worksheet.
Selecting a user and clicking 'delete' deletes their user data on the worksheet. I have modified the code so that when a user is added or deleted, it should check each worksheet and adds or deletes rows accordingly.
This is the code to delete the pupil data on a single sheet:
Private Sub cmbDelete_Click()
Dim msgResponse As String 'confirm delete
Application.ScreenUpdating = False
'get user confirmation
msgResponse = MsgBox("This will delete the selected record. Continue?", _
vbCritical + vbYesNo, "Delete Entry")
Select Case msgResponse 'action dependent on response
Case vbYes
'c has been selected by Find button on UserForm
Set c = ActiveCell
c.EntireRow.Delete 'remove entry by deleting row
'restore form settings
With Me
.cmbAmend.Enabled = False 'prevent accidental use
.cmbDelete.Enabled = False 'prevent accidental use
.cmbAdd.Enabled = True 'restore use
'clear form
Call ClearControls
End With
Case vbNo
Exit Sub 'cancelled
End Select
Application.ScreenUpdating = True
End Sub
I have tried modifying it to delete the user data on each worksheet, as follows:
Private Sub cmbDelete_Click()
Dim Sh As Worksheet
Dim msgResponse As String 'confirm delete
Application.ScreenUpdating = False
'get user confirmation
msgResponse = MsgBox("This will delete the selected record. Continue?", _
vbCritical + vbYesNo, "Delete Entry")
Select Case msgResponse 'action dependent on response
Case vbYes
For Each Sh In ThisWorkbook.Sheets
With Sh.UsedRange
'c has been selected by Find button
Set c = ActiveCell
c.EntireRow.Delete 'remove entry by deleting row
End With
Next
'restore form settings
With Me
.cmbAmend.Enabled = False 'prevent accidental use
.cmbDelete.Enabled = False 'prevent accidental use
.cmbAdd.Enabled = True 'restore use
'clear form
Call ClearControls
End With
Case vbNo
Exit Sub 'cancelled
End Select
Application.ScreenUpdating = True
End Sub
but this version deletes the user's data and the data on the 4 rows beneath them. It does not delete data from the next worksheet at all.
Can anyone offer any advice please?
change:
Case vbYes
For Each Sh In ThisWorkbook.Sheets
With Sh.UsedRange
'c has been selected by Find button
Set c = ActiveCell
c.EntireRow.Delete 'remove entry by deleting row
End With
Next
to:
Case vbYes
Dim l As Long
l = ActiveCell.Row 'store currently active cell row
For Each Sh In ThisWorkbook.Worksheets
Sh.Rows(l).Delete
Next
should you ever be interested in knowing why your previous code didn't work:
1)
Set c = ActiveCell
would set c to the currently active cell, i.e. the cell your "Find" button selected in the currently active sheet
2) while
c.EntireRow.Delete
would always, quite unsurprisingly, delete c entire row, i.e. the same row in the sheet where c has been found in, since nobody is setting c again and point to another sheet range.
and simply looping through Sheets collection doesn't change the Active sheet
I am having an issue regarding setting a range of cells to be editable by a user after my code runs when the file opens. The file gets a runtime error "Unable to set the locked property of the range class".
I have done some digging online and it appears other people have the same issue when their cells are merged. My cells aren't merged.
What I am trying to do:
Lock all cells on all sheets apart from specific ones
Still allow user to group and ungroup data
The code runs fine without selecting specific cells
Sub Workbook_Open()
Application.StatusBar = "Loading Please Wait..." 'change status bar text
Application.ScreenUpdating = False 'freeze screen
Application.Cursor = xlWait 'change cursor
UserForm1.Show vbModeless 'show loading form
UserForm1.Repaint 'update form
For Each ws In Sheets 'loop for every sheet
With ws
.Unprotect Password:="11Oceans" 'unprotect sheet
.Range("D6:J6").Locked = False 'format certain cells to unprotect -ERROR HERE
.Protect Password:="11Oceans", UserInterfaceOnly:=True 'protect sheet but leave data grouping
.EnableOutlining = True
End With
Next ws 'next worksheet
Application.ScreenUpdating = True 'return control to user
Application.StatusBar = "" 'return status bar to default
Application.Cursor = xlDefault 'return cursor to default
Unload UserForm1 'close loading form
End Sub
I have a group of cells B32 till R32 length and B32 to B51 breadth. I want to keep this block hidden at the start when the sheet is opened. I have named this block as 'Analysis'.
There is a button in the sheet. When the button is pressed, I want to unhide that block. I am new to Excel Vba. I would like to know the syntax/code for doing this operation.
Thanks in advance.
Ananda
You cant just hide an area like MattCrum has mentioned.
You have 3 choices as far as I am concerned
Now, just make sure you have something(data - not empty cells) in the Range 32:51 and your main sheet is either called Sheet1 or change Sheet1 in the code to suit your worksheets name
1)
in VBE ( Visual Basic Editor ) double click ThisWorkbook in the project explorer and paste this code
Private Sub Workbook_Open()
ThisWorkbook.Sheets("Sheet1").Rows(32 & ":" & 51).hidden = True
End Sub
Right click on the folder Modules and Insert a new Module, then paste this code
Sub unhide()
ThisWorkbook.Sheets("Sheet1").Rows(32 & ":" & 51).hidden = False
End Sub
Now, add a button on the spreadsheet, right click and assign macro called unhide to it.
Save changes and save your workbook as *.xlsm file
Notice when you open the workbook now, rows 32 to 51 are hidden. Clicking the button will unhide them.
2) You can change the font color to white to "hide" the contents.
Follow step 1, and replace
ThisWorkbook.Sheets("Sheet1").Rows(32 & ":" & 51).hidden = True
with this
ThisWorkbook.Sheets("Sheet1").Range("B32:R51").Font.Color = RGB(255, 255, 255)
and the code in the Module ( the unhide subroutine )with
ThisWorkbook.Sheets("Sheet1").Range("B32:R51").Font.Color = RGB(0, 0, 0)
Now, everything works similar to step 1 except your are "hiding"(changing) the font color instead of hiding rows. Not a great approach, but if it works for you then cool
3) Follow step 1 and replace the code under ThisWorkbook with
Option Explicit
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet1")
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "hiddenSheet"
Set hs = ThisWorkbook.Sheets(Worksheets.Count)
hs.Visible = xlSheetHidden
ws.Range("B32:R51").Select
Selection.Copy
With hs
.Activate
.Range("B32").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
ws.Activate
ws.Rows(32 & ":" & 51).Delete
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call deleteHidden(Worksheets.Count)
End Sub
And the code in the Module1 with
Option Explicit
Public ws As Worksheet, hs As Worksheet
Sub unhide()
With hs
.Activate
.Rows("32:51").Select
Selection.Copy
End With
With ws
.Activate
.Rows("32:32").Select
Selection.Insert Shift:=xlDown
End With
End Sub
Sub deleteHidden(num&)
Application.DisplayAlerts = False
Worksheets(num).Delete
Application.DisplayAlerts = True
Set hs = Nothing
End Sub