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
Related
I have the following set of code to record daily employees who eat lunch in the canteen. What change is needed so that when the person clicks on the macro button every day, the data is on the 1st blank line (from column A) of the "dados_diarios" sheet?
This is so that at the end of the month I have a list of all the days.
Sub outros_diario()
Sheets("outros").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Workbooks.Open ("N:\RH\Cantina\Lista_OUTROS.xlsx")
Windows("Lista_OUTROS.xlsx").Activate
Cells.Select
Selection.Copy
Windows("outros.xlsm").Activate
Sheets("outros").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
ActiveWindow.DisplayGridlines = False
Range("B8:O1000").Select
Selection.Copy
Sheets("dados_diarios").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C2:F1000").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("E2:H1000").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Range("H8").Select
Columns("C:C").EntireColumn.AutoFit
End Sub
Give this a go. You may want to add back in your DisplayGridlines= False and the deletion of cells at the end - but it should give you a much better start than where you're up to right now:
Sub outros_diario()
'declarations
Dim last_row_source As Long
Dim last_row_destination As Long
Dim source_book As Workbook
Dim source_sheet As Worksheet
Dim dest_sheet1 As Worksheet
Dim dest_sheet2 As Worksheet
'set references to the two paste destinations
Set dest_sheet1 = ThisWorkbook.Sheets("outros")
Set dest_sheet2 = ThisWorkbook.Sheets("dados_diarios")
'delete-clear sheet: outros
dest_sheet1.Cells.Delete Shift:=xlUp
'open the workbook as reference 'source_book'
Set source_book = Workbooks.Open("N:\RH\Cantina\Lista_OUTROS.xlsx")
'set a reference to the activesheet and call it 'source_sheet'
Set source_sheet = source_book.ActiveSheet
'copy source_sheet to dest_sheet1 [outros]
source_sheet.Cells.Copy dest_sheet1.Range("A1")
'find where the data now stops on the [outros]
last_row_source = dest_sheet1.Cells(dest_sheet1.Rows.Count, "B").End(xlUp).Row
'find where the data stops on [dados_diarios]
last_row_destination = dest_sheet2.Cells(dest_sheet2.Rows.Count, "B").End(xlUp).Row
'copy data values from [outros] to [dados_diarios] ignoring first 7 rows
dest_sheet2.Range("A" & last_row_destination + 1).Resize(last_row_source - 7, 14).Value = dest_sheet1.Range("B8:O" & last_row_source).Value
'close the source workbook, without saving
source_book.Close False
End Sub
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
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
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
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