ActiveSheet.Paste Error on protected sheet - excel

I have 2 worksheets (Input & Record), I just want to copy some data from "Input" to "Record", it worked but if I protect "Record".... Paste method of Worksheet class Failed comes up.
So I added script for unprotected sheets and protect sheets, but '1004' stil comes up.
Here the detail of my project.
Input sheet is area for me to input some value to a row. In 1 row at least have 10 values at different column.
Maximum row that I can add is ten rows.
Record sheet is database as Table1 based on how much row from Input sheet that i'll add.
Here my script
Sub adddata() 'this sub code from button on "Input" sheet
Sheets("Input").Select
Range("C15").Offset(1, 0).Select 'select range start from C16
If Range("M27") = 1 Then 'value for how much row that i'll add
Range(Selection, Selection.End(xlToRight)).Select
Else
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
End If
Selection.Copy
Sheets("Record").Select
Worksheets("Record").Unprotect Password:="4321"
If Range("B2").Offset(1, 0).Value = "" Then
Range("B2").Offset(1, 0).Select
Else
Range("B2").End(xlDown).Offset(1, 0).Select
End If
ActiveSheet.Paste '<< The trouble maker
Application.CutCopyMode = False
Worksheets("Record").Protect Password:="4321", UserInterfaceOnly:=True
End Sub
That I want to know:
What I've missed?
The solution of this dilemma.

I think all this Select process is not necessary and you can avoid that. I can edit my answer if you will add your intentions "what you are trying to do".
You want to copy some range from Input and paste it to Record always to the next empty row?
If I understood you correct, maybe something like this?
Sub adddata()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Record").Unprotect Password:="4321"
Dim NextFreeCell As Range
Set NextFreeCell = ThisWorkbook.Worksheets("Record").Cells(Rows.Count, "B").End(xlUp).Offset(RowOffset:=1)
With ThisWorkbook.Worksheets("Input")
If .Range("B2").Value = 1 Then
.Range("C15", .Range("C15").End(xlToRight)).Copy
Else
.Range("C15", .Range("C15").End(xlDown).End(xlToRight)).Copy
End If
End With
NextFreeCell.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Worksheets("Record").Protect Password:="4321", UserInterfaceOnly:=True
ThisWorkbook.Worksheets("Input").Activate
Application.ScreenUpdating = True
Application.CutCopyMode = False
Exit Sub
ErrorHandler:
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Input").Activate
Application.ScreenUpdating = True
ThisWorkbook.Worksheets("Record").Protect Password:="4321", UserInterfaceOnly:=True
End Sub
Here is how it works:
This was not included in your original question. So you have to create a new question with additional information to your original question. However this time I will answer here but not next time.
Here is the code for table:
Sub adddata()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Record").Unprotect Password:="4321"
With ThisWorkbook.Worksheets("Record").ListObjects("Table1").ListRows.Add
With ThisWorkbook.Worksheets("Input")
If .Range("B2").Value = 1 Then
.Range("C15", .Range("C15").End(xlToRight)).Copy
Else
.Range("C15", .Range("C15").End(xlDown).End(xlToRight)).Copy
End If
End With
.Range.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
ThisWorkbook.Worksheets("Record").Protect Password:="4321", UserInterfaceOnly:=True
ThisWorkbook.Worksheets("Input").Activate
Application.ScreenUpdating = True
Application.CutCopyMode = False
Exit Sub
ErrorHandler:
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Input").Activate
Application.ScreenUpdating = True
ThisWorkbook.Worksheets("Record").Protect Password:="4321", UserInterfaceOnly:=True
End Sub
Remove all empty cells in table below your last data. This code will add a new line to table. Also table name should correspond to your table name. Can be found in Excel under Format Table

Try this.
Sub adddata()
Worksheets("Record").Unprotect Password:="4321" ' Unlock the target sheet before copying.
Sheets("Input").Select
Range("C15").Offset(1, 0).Select
If Range("M27") = 1 Then
Range(Selection, Selection.End(xlToRight)).Select
Else
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
End If
Selection.Copy
Sheets("Record").Select
If Range("B2").Offset(1, 0).Value = "" Then
Range("B2").Offset(1, 0).Select
Else
Range("B2").End(xlDown).Offset(1, 0).Select
End If
Activecell.PasteSpecial xlAll
Application.CutCopyMode = False
Worksheets("Record").Protect Password:="4321", UserInterfaceOnly:=True
End Sub

Related

Is there a way to speed up my code that selects a lot of cells for formatting and creates external sheets faster? Is there a worksheet selection alt?

This demo will be scaled up to perform this operation on data ranges with 100's of rows, so I'm not sure how to make the runtime faster, and avoid selecting different sized ranges using the xlToRight if there was adjacent data. Attached is a view-only xlsm.
spreadsheet
Sub Main_Loop()
' This script references the number of unique items in the
' filter then loops the data extraction based on this value.
'
' Keyboard Shortcut: Ctrl+Shift+Z
'
' Nate_Ayers
Application.ScreenUpdating = False
Range("H1").Select
Dim i As Integer 'counter
Dim Loop_var As String
Loop_end = Range("A2").Value2 'Stop loop at end of unique items
For i = 1 To Loop_end
Selection.Copy
Range("A3").Select 'Helper cell location chosen where data wont overwrite the cell
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Paste values only (avoids unique function)
Application.CutCopyMode = False
Selection.Copy
Columns("C:C").AutoFilter
ActiveSheet.Range("C:C").AutoFilter Field:=1, Criteria1:=Range("A3")
'Data block grab:
Range("C2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Range("A2").Select
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Worksheets(ActiveSheet.Index).Select 'could have efficiency improvement
Worksheets(ActiveSheet.Index).Name = Selection 'Name the sheet
Range("A1").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Sheets("Demo").Select
Range("A3").Select
Selection.ClearContents
Selection.AutoFilter
Range("H1").Select
ActiveCell.Offset(0, i).Select 'Reference next row to repeat operations
Next i
Application.ScreenUpdating = True
End Sub
It's hard to know what some of your subroutine is doing without seeing the underlying spreadsheet, and some of the variables don't seem to be referenced. But here are a few examples of how you might be able to speed things up. As already mentioned the main issue is the unnecessary use of copy and paste. This probably won't be a solution that works, but I hope it helps you on the way.
Sub Main_Loop()
Dim vCalc, vEvents As Variant
Dim ws, new_ws As Worksheet
Dim i As Integer 'counter
Application.ScreenUpdating = False
vCalc = Application.Calculation
Application.Calculation = xlCalculationManual
vEvents = Application.EnableEvents
Application.EnableEvents = False
Set ws = ActiveSheet
i = 1
While ws.Range("H" & i) <> ""
ws.Range("A3").Value = ws.Range("H" & i).Value
ws.Range("C:C").AutoFilter Field:=1, Criteria1:=Range("A3")
Set new_ws = Sheets.Add(After:=ActiveSheet)
ws.Range("C2").CurrentRegion.Copy
new_ws.Range("A2").Paste
new_ws.Name = new_ws.Range("A2").Value
new_ws.Range("A1").Value = new_ws.Range("A2").Value
new_ws.Range("A1").Font.Bold = True
i=i+1
Wend
ws.Range("A3").ClearContents
Application.ScreenUpdating = True
Application.Calculation = vCalc
Application.EnableEvents = vEvents
End Sub

how do you paste unique values without showing the rows that were skipped?

I'm trying to extract the unique purchase orders from a row and paste that list into another sheet. The problem is that when I paste, it doesn't list the purchase orders sequentially (a1,a2,a3,a4); It pastes them from the location that they were copied (a3,a112,a194, etc)
here's the macro:
Sub unique_values()
'
' unique_values Macro
'
'
Columns("A:A").Select
Selection.Copy
Sheets("Sheet1").Select
Sheets.Add After:=ActiveSheet
Columns("A:A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Range("A1:A394").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End Sub
Just updated you code a little. You were almost there. Just delete the empty cells after you copy.
Columns("A:A").Select
Selection.Copy
Sheets("Sheet1").Select
Sheets.Add After:=ActiveSheet
Columns("A:A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.CutCopyMode = False
Range("A1:A394").RemoveDuplicates Columns:=Array(1)
On Error Resume Next
With Range("A:A")
If WorksheetFunction.CountA(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
End With

Condition dosen't work on filtered data

Filter data with number > 0
Select the cells visible with data and make them "0"
Remove filter
My code works fine when there are NO ROWS and more than ONE ROW after filter. But fails when there is only one row left after filter. Can somebody help ?
Rows("1:1").Select
Range("C1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$J$98").AutoFilter Field:=3, Criteria1:=">0", Operator:=xlAnd
Range("C1").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
If ActiveCell = vbNullString Then
ActiveSheet.Range("$A$1:$J$98").AutoFilter Field:=3
Else
ActiveCell.FormulaR1C1 = "0"
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
ActiveSheet.Paste
ActiveSheet.Range("$A$1:$J$98").AutoFilter Field:=3
End If
Sub FilterAndCopy()
With Range("A1:J98")
.AutoFilter Field:=3, Criteria1:=">0"
.Copy Range("THE_RANGE_YOU_NEED_TO_COPY_TO")
.AutoFilter
End With
End Sub
Explanation
After filtering a range, the Copy method copies only visible cells. The Destination argument of Copy is the location where you want to paste data (it could be any worksheet).
It is simpler if you use the SpecialCells(xlVisible) and the Intersect commands.
Sub tt()
Set sh = ActiveSheet
If sh.FilterMode Then sh.AutoFilterMode = False
Set r = sh.Range("$A1:$J$98")
Field = 3
r.AutoFilter Field:=Field, Criteria1:=">0", Operator:=xlAnd
Set FilterData = Intersect(r, r.Offset(1))
Set VisibleData = Nothing
On Error Resume Next
Set VisibleData = FilterData.SpecialCells(xlVisible)
On Error GoTo 0
If VisibleData Is Nothing Then
Else
VisibleData.Columns(Field).Cells.Formula = "0"
End If
sh.AutoFilterMode = False
End Sub

Why does VBA macro stop on active cell change?

I have been away for 7 years from writing VBA and today I have been asked to do a simple thing and it doesn't work
I am trying to take the contents of 52 weekly summaries and put them all into one sheet:
So I can go to the first sheet - copy the data I need - go to the summary sheet - paste the data - and then it stops ... same if I just change the value of a cell - it changes the value and then stops.
Am I missing a security setting or something?
Here is the VBA
Sub Macro3()
'
' Macro3 Macro
'
' Take cell contents of active sheet and paste into summary sheet
Sheets("we 03 Jan").Select
Do
shtName = ActiveSheet.Name
Range("A10:U39").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Full Year").Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.Value = shtName
' stops here
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' stops here if previous line causing stop is removed
Sheets(shtName).Select
If ActiveSheet.Index = Worksheets.Count Then
Worksheets(1).Select
Exit Sub
Else
ActiveSheet.Next.Select
End If
Loop
End Sub
Does this work?
Sub Macro3()
Dim n As Long
Dim ws As Worksheet
On Error GoTo clean_up
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Sheets("we 03 Jan").Select
For n = ActiveSheet.Index To Sheets.Count
Set ws = Sheets(n)
ws.Range("A10:U39").Copy
With Sheets("Full Year").Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = ws.Name
.Offset(1, 0).PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Next n
clean_up:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

VBA code inconsistently crashes Excel (run-time error 80010108)

I'm using the following VBA code to automate moving a row on one sheet to another. About 1/3 of the time, it gives a "run-time error '-2147417848 (80010108)" and then crashes Excel. I cannot find a common reason why. After a crash, I can execute the same code on the same row, and it may or may not work fine the next time.
Can anyone tell why this code below should be unstable?
Sub Move_to_Sheet2 ()
'
' Move_to_Sheet2 Macro
'
' Keyboard Shortcut: Ctrl+r
'
Rows(ActiveCell.Row).Select
Selection.Copy
Set Rng = Nothing
Sheets("Sheet2").Select
Rows("4:4").Select
Selection.Insert Shift:=xlDown
Sheets("Sheet1").Select
Selection.Delete Shift:=xlUp
ActiveWorkbook.save
End Sub
You need to fully qualify your Rows. See this example.
Sub Move_to_Sheet2()
Dim ws As Worksheet
'~~> Change this to the relevant sheet name
Set ws = Sheets("Sheet1")
With ws
.Rows(ActiveCell.Row).Copy
Sheets("Sheet2").Rows("4:4").Insert Shift:=xlDown
.Rows(ActiveCell.Row).Delete
End With
ActiveWorkbook.Save
End Sub
Sub Test()
' Test Macro
Range("A24:C30").Select
Selection.Copy
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 10
Range("A31").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Sheets("Save Sales").Select
Range("B6").Select
Selection.Insert Shift:=xlDown
Sheets("Invoice").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("B9").Select
MsgBox "Print Now"
End Sub

Resources