I have written a script in the workbook that sends a msgbox warning users not to copy and paste cells whenever they do so.
Target.PasteSpecial xlPasteValues
If Application.CutCopyMode = xlCopy Then
MsgBox ("Please do not copy and paste cells. This can cause errors in log sheet")
ElseIf Application.CutCopyMode = xlCut Then
MsgBox ("Please do not copy and paste cells. This can cause errors in log sheet")
End If
Application.CutCopyMode = False
The problem is I have made other scripts assigned to buttons which are used to copy and paste specific cells when the function is called, but I get my own warning message pop up when this happens. Is there a way to prevent the msgbox popping up in these instances?
I have tried;
Application.DisplayAlerts = False
Application.DisplayAlerts = True
But this doesn't seem to work with scripted msgboxes
Don't use copy/Paste method for many reasons.
Slow
Less Reliable, especially with pastespecial
Is causing you issues in this case.
Try instead to make values or formulas = source values or formulas.
Example:
Copy/Paste:
Sub Copy_Paste()
Dim srcRG As Range 'Source Range
Dim dstRG As Range 'Destination Range
Set srcRG = Sheet1.Range("B2:B6")
Set dstRG = Sheet1.Range("C2:C6")
'Copy all
srcRG.Copy dstRG
'Or Copy Values
srcRG.Copy
dstRG.PasteSpecial xlPasteValues
'Or Copy formulas
srcRG.Copy
dstRG.PasteSpecial xlPasteFormulas
End Sub
Becomes:
Sub Values_Formulas()
Dim srcRG As Range 'Source Range
Dim dstRG As Range 'Destination Range
Set srcRG = Sheet1.Range("B2:B6")
Set dstRG = Sheet1.Range("C2:C6")
'Copy values
dstRG.Value = srcRG.Value
'Or Copy formulas
dstRG.Formula = srcRG.Formula
'Or Copy cell color
dstRG.Interior.Color = srcRG.Interior.Color
End Sub
Won't throw error.
At the Bottom of this link you can find a list of properties you can copy this way
Related
My intent is to copy a range together with the objects(radio button) and paste it at an dynamic location (at an offset of 15 columns) then update all the cell references of the newly pasted objects relative to their position. i.e. if location of radio button (object) = "AF22" then linked cell = 1st column of new range + 11 columns to the right (e.g. Column T + 11 columns = Column "AD") hence new cell reference = "AD22"
EDIT: I've removed a part of my code which seemed redundant. The below code perfectly copies and pastes the data and objects. However I need help in the Linkedcell part
`Sub Macro2()
Dim rng, rng1, rng2 As Range, s As Shape, ws As Worksheet, sr As
ShapeRange, Loc As String
Set ws = ActiveWorkbook.ActiveSheet
Set rng = ActiveSheet.Range("E19")
Set rng1 = ActiveSheet.Range("T19:AF34")
Set rng2 = ActiveSheet.Range("E19:Q34")
'Copy the range with text and paste it to the desired location
ActiveSheet.Range("E19:Q34").copy
With rng
rng.Offset(0, 15).Select
ws.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
'Trying to find option buttons and give them a new cell reference.(linked cell)
With ActiveSheet
'Selection = Range("V19:AC34")
For Each s In .Shapes
'if s.TopLeftCell.Column =
' .Range ("V19:AC34")
If s.Name Like "OptionButton*" Then
s.DrawingObject.LinkedCell = "=" & Chr(s.TopLeftCell.Column) & CStr(s.TopLeftCell.Row)
Debug.Print s.DrawingObject.LinkedCell
'Loc = "AD" & s.TopLeftCell.Row
'Debug.Print Loc
'.Value = xlOff
'Selection.LinkedCell = Range(Loc).Address
'.Display3DShading = False
End If
'End With
Next s
End With
End Sub`
Try the next code to select/copy a shape of a range selection:
Dim ws As Worksheet, s As Shape, rng As Range, optB As OLEObject
Set ws = ActiveSheet
Set rng = sh.Range("your range containing the Option Button to be copied")
With ws
For Each s In .Shapes
If Not Intersect(Range(s.TopLeftCell.Address), Range(rng.Address)) Is Nothing Then
If s.Name = "OptionButton1" Then 'use here your option button name
s.Copy
Exit For
End If
End If
Next s
End With
rng.Cells(1, 1).Offset(0, 15).Select
ws.Paste
'Generic way of identifying the newly pasted Option button and allocate a `LinkedCell` to it:
'Set optB = ws.Shapes(ws.Shapes.Count).OLEFormat.Object
'optB.LinkedCell = "=" & rng.Cells(1, 1).Offset(0, 15).Address
Selection.LinkedCell = rng.Cells(1, 1).Offset(0, 15).Address
A trick must be used in order to do that, but using the ActiveSheet.Shapes...
Using of rng.Cells.Offset(0, 15).Select is not wise. This will select so many cells as the range has. I have chosen to paste it referring the first cell of the range. If you want/need a different position, it will be easy to adapt the code (rng.Cells()), I think.
Edited: I adapted the code to select and copy only a shape named "OptionButton1". Please, take care to use here your real shape name!
I also showed a way to allocate a LinkedCell to the newly created Option Button. I must confess that, looking to your code, I did not understand what cell you tried to link. I used a generic one, the same used for moving the shape. Please use here an appropriate address, according to your need.
I am trying to use VBA to realize the following goal:
I have two sheets: "revenue" and "sales tax", and they record the revenue and sales tax of 100 stores from May 1st to May 28th. Now I am trying to create a sheet for each store recording its revenue and sales tax from May 1st to May 28th.
Sub test1()
Sheets("Sheet1").Select
Sheets("Sheet1").Copy Before:=Sheets(17)
Sheets("revenue").Select
Range("D154:D168").Select
Selection.Copy
Sheets("Sheet1 (2)").Select
Range("C5").Select
ActiveSheet.Paste
Sheets("sales tax").Select
Range("D138:D152").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1 (2)").Select
Range("F5").Select
ActiveSheet.Paste
Sheets("Sheet1 (2)").Select
Sheets("Sheet1 (2)").Name = " reportF "
End Sub
Using this code I am only able to establish a file for 1 store each time. What loop syntax should I use to loop through all stores?
It looks like your data has the store name in column D? This code runs down all cells in column D and copies them into separate sheets depending on the contents
Sub ExampleCode
Dim r as range 'declare a pointer variable
Dim ws as worksheet 'declare a worksheet variable
set r = Range("d1") 'point to fist cell
Do 'Start a loop
If SheetNotExist(r.text) then 'if no sheet of that name
set ws = worksheets.add(after:=worksheets.count) 'add one
ws.name = r.text 'and name it as text in r
End if
r.copy worksheets(r.text).cells(rows.count,4).end(xlup).offset(1,0) 'copy to next blank cell
set r = r.offset(1,0) 'shift pointer down one cell
Loop until r.text = "" 'keep going until r is empty
End Sub
Function SheetNotExist(s as string) as boolean 'check if sheet exists
On error goto nope 'jump on error
Dim ws as worksheet
set ws = worksheets(s) 'this will error if sheet doesn't exist
'so if we get here the sheet does exist
SheetNotExist = False 'so return false
Exit Function 'and go back
nope: 'we only get here if sheet doesn't exist
SheetNotExist = True 'so return that
End Function
Written on my phone - don't have excel so there may be typos - code may not compile therefore,
I am trying to build a vba code. Some bits are working some not. Working: It is collecting valued cells from Customers workbook and pasting in new sheet in supplier workbook. New sheet is renamed on cell name. Not working: I also want to copy a header which is in Supplier workbook named as template. The last bit i want VBA code run through each column.
Sub Copy_Past_Repeat()
Dim rs As Worksheet
Dim rng As Range
Windows("Customer.xlsm").Activate
Set rng = Range("n1:n1000") 'column
rng.SpecialCells(xlCellTypeConstants).Select 'Selecting only hardcoded data
Selection.Copy
Windows("Supplier.xlsm").Activate
Sheets.Add after:=ActiveSheet
Range("C2").Select
ActiveSheet.Paste
ActiveSheet.Name = ActiveSheet.Range("C2")
'not working
ThisWorkbook.Sheets("Template").Range("A1:E1").Select
Selection.Copy
ActiveSheet.Paste 'should be pasted in just crated spreadsheet Name=(C2)
Application.CutCopyMode = False
End Sub `
It is highly recommended to avoid using .Select, .Activate or similar actions.
See How to avoid using Select in Excel VBA
Also always specify in which worksheet or workbook a range is. Otherwise Excel cannot know it and guesses.
Option Explicit
Sub Copy_Past_Repeat()
Dim rng As Range
Set rng = Workbooks("Customer.xlsm").Range("N1:N1000") 'column
rng.SpecialCells(xlCellTypeConstants).Copy 'Copy only hardcoded data
Dim NewWs As Worksheet
With Workbooks("Supplier.xlsm")
Set NewWs = .Sheets.Add(After:=.ActiveSheet) 'remember the new added sheet in NewWs so we can access it later
NewWs.Range("C2").Paste
NewWs.Name = NewWs.Range("C2")
ThisWorkbook.Worksheets("Template").Range("A1:E1").Copy
NewWs.Paste 'should be pasted in just crated spreadsheet Name=(C2)
'here you should specify where in the sheet to paste
'NewWs.Range("A1").Paste
End With
Application.CutCopyMode = False
End Sub
I have the below code that copies cells from one excel sheet and pastes special values into a text file.
now from the sheet I'm copying, I have a lot of cells which contain #N/A.
can anyone suggest how to exclude these cells?
thanks
Private Sub CommandButton3_Click()
Dim i As Long
Dim wb As Workbook
Dim NewWB As Workbook
Dim saveFile As String
Dim WorkRng As Range
On Error Resume Next
i = Sheets(1).Range("W158:W" & Range("W158").End(xlDown).Row).Rows.Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = ActiveWorkbook
Set NewWB = Application.Workbooks.Add
Thispath = wb.path
wb.Sheets(2).Range("W158:W" & i + 5).Copy
NewWB.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
NewWB.SaveAs filename:=Thispath & "\textfile.txt", FileFormat:=xlText,
CreateBackup:=False
NewWB.Close
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
The only way i can think of is to do a basic for loop to go through all the cells individually and check for their value
For Each cell In activehseet.Range("W158:W" & i + 5)
With cell
If .Value = "#N\A" Then
Exit Sub
Else
.Copy
'code to paste here
End With
Next cell
This unfortunately would take quite a while to run and would only get longer the larger the size of the database. I would suggest losing any rows/columns that aren't in use to speed this up.
However it is probably the easiest method to fix your problem
It could be possible by using an array but as I am not an expert with array manipulation i couldn't be sure. I'm sure someone a lot smarter than me could help you through that
Hope this helps get you started. Great question!
You can try to wrap your formulas in IFERROR, just select all cells which you want to wrap and run the following macro:
Sub WrapFormulasWIthIFERROR()
Dim Cell As Range
For Each Cell In Selection
If Cell.HasFormula Then
If Left(Cell.Formula, 9) <> "=IFERROR(" Then
Cell.Formula = "=IFERROR(" & Mid(Cell.Formula, 2) & ","""")"
End If
End If
Next
End Sub
If the cell value is N/A, the result will be an empty cell. Just be aware to not select the whole sheet, because it will run forever.
I'm stuck with this problem. I need to run a macro that will do the following:
Find the last line in a table on the worksheet called "Baseline".
Add a row to that table
Copy the formats and formulas (but not values) from the row above to the new row.
Repeat the process for the other worksheets (called Quarter 1, Quarter 2 etc), that have the same structure as the worksheet called Baseline.
My problem is that the process only seems to work on the first worksheet, Baseline, but not on any of the other worksheets. I wonder if the problem is the way I have tried to get the code to copy formulas and formats only.
Here is the code, just for the Baseline and Quarter 1 worksheets:
Public Sub AddRow()
On Error GoTo errhandler
Worksheets("Baseline").Activate
'Find Last Row in Service User Details
Dim rgeLastRowBaseline As Range
Set rgeLastRowBaseline = ActiveWorkbook.Worksheets("Baseline").Cells.Find("Cost")
' Select and Copy Last Row
rgeLastRowBaseline.End(xlDown).EntireRow.Select
Selection.Offset(1).EntireRow.Insert
rgeLastRowBaseline.End(xlDown).EntireRow.Select
Selection.Copy
rgeLastRowBaseline.End(xlDown).Offset(1).EntireRow.Select
rgeLastRowBaseline.End(xlDown).Offset(1).EntireRow.PasteSpecial
Application.CutCopyMode = False
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.ClearContents
'Quarter 1
Worksheets("Quarter 1").Activate
Dim rgeLastRowQ1 As Range
Set rgeLastRowQ1 = ActiveWorkbook.Worksheets("Quarter 1").Cells.Find("Cost")
' Select and Copy Last Row
rgeLastRowQ1.End(xlDown).EntireRow.Select
Selection.Offset(1).EntireRow.Insert
rgeLastRowQ1.End(xlDown).EntireRow.Select
Selection.Copy
rgeLastRowQ1.End(xlDown).Offset(1).EntireRow.Select
rgeLastRowQ1.End(xlDown).Offset(1).EntireRow.PasteSpecial
Application.CutCopyMode = False
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.ClearContents
Exit Sub
errhandler:
Application.CutCopyMode = False
End Sub
Does anyone have any suggestions please?
Thanks
You'll need to use Worksheet type variables. I did not correct your technical solutions even though I don't completely agree with selecting everything.
Sub onesheet(ws As Worksheet)
On Error GoTo errhandler
ws.Activate
Dim rgeLastRowQ1 As Range
Set rgeLastRowQ1 = ws.Cells.Find("Cost")
' Select and Copy Last Row
rgeLastRowQ1.End(xlDown).EntireRow.Select
Selection.Offset(1).EntireRow.Insert
rgeLastRowQ1.End(xlDown).EntireRow.Select
Selection.Copy
rgeLastRowQ1.End(xlDown).Offset(1).EntireRow.Select
rgeLastRowQ1.End(xlDown).Offset(1).EntireRow.PasteSpecial
Application.CutCopyMode = False
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.ClearContents
Exit Sub
errhandler:
Application.CutCopyMode = False
End Sub
Sub sheetloop()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Baseline" Or ws.Name Like "Quarter*" Then Call onesheet(ws)
Next ws
End Sub