My paste link does not seem to work and is giving me a select method of range class failed on the specified line. I don't seem to be able to diagnose this error.
Sub CustomizedInputFixedoutputnotworking()
Dim rng As Range, _
inp As Range, _
ws As Worksheet
Set inp = Selection
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled", vbInformation
Exit Sub
Else
Worksheets("Sheet 2").Range("B2:N5").Select ' Code does not work at this line
Worksheets("Sheet 2").Paste Links:=True
End If
Application.CutCopyMode = False
End Sub
Try this code:
Sub CustomizedInputFixedoutputnotworking()
Dim rng As Range, _
inp As Range, _
ws As Worksheet
Set inp = Selection
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled", vbInformation
Exit Sub
Else
rng.Copy ' add this line to copy the range that user selected before (with InputBox)
Worksheets("Sheet 2").Activate ' add this line to activate the target worksheet, because select method (the next line) only work in the active sheet
Range("B2:N5").Select
ActiveSheet.Paste Link:=True
End If
Application.CutCopyMode = False
End Sub
NOTE: Copy method will fail if the user select non-contiguous ranges for example A1 and B2, the simple way (not the complete way) to avoid that is by using:
Set rng = Union(rng, rng)
If rng.Areas.Count > 1 Then Exit Sub
I believe your issue is that you selected the text but never copied it to the clipboard. Even if you did copy it, the .Select method would have changed your destination.
I am hopeful a simple change to the .Copy method will resolve your issue. If not, let me know:
Worksheets("Sheet2").Range("B2:N5").Copy
Worksheets("Sheet2").Paste Link:=True
-- edit --
Based on the comment that the selected range is the "copy" (source) and B2:N5 is the destination, try this:
rng.Copy
Worksheets("Sheet2").Range("B2:N5").Select
Worksheets("Sheet2").Paste Link:=True
Related
I was wondering if i could get your advice.
I have the below code which works for copying and creating additional tabs by splitting values from a column into 2 tabs and on each tab it applies an autofilter.
However when it creates the 3rd tab it shows an error message that there is not enough memory to continue.
I think that the deleting hidden rows as part of the auto-filter is causing the code to fall down but i have tried to amend the code to clear memory etc but it keeps failing.
Can i please get your help!!
Option Explicit
'---------------------------------------------------------------------------------------
' Module : Module1
' DateTime : 24/09/2006 22:48
' Updated : 2014
' Author : Roy Cox (royUK)
' Website : more examples
' Purpose : Create a sheet for each unique name in data
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
' projects but please leave this header intact.
'---------------------------------------------------------------------------------------
Sub ExtractToSheets()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim rData As Range, rList As Range, rDelete As Range
Dim rCl As Range
Dim sNm As String
Const Crit1 As String = "Category"
Const Crit2 As String = "Store"
Set ws = Sheets("sheet1")
On Error GoTo exit_Proc
'extract a list of unique names
'first clear existing list
With ws
Set rData = .Range("A1").CurrentRegion
.Columns(.Columns.Count).Clear
rData.Columns(4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
Set rList = .Cells(1, .Columns.Count).CurrentRegion
Set rList = rList.Offset(1, 0).Resize(rList.Rows.Count - 1, _
rList.Columns.Count)
For Each rCl In rList
sNm = rCl.Text
''///delete any previously created sheets(only if required-NB uses UDF)
If WksExists(sNm) Then
Application.DisplayAlerts = False
Sheets(sNm).Delete
Application.DisplayAlerts = True
End If
Select Case sNm
Case "Store", "Category"
''/// ignore these names
Case Else
Sheets("sheet1").Copy After:=Worksheets(Worksheets.Count)
With ActiveSheet
.Name = sNm
If Not .AutoFilterMode Then .Range("A1").AutoFilter
ActiveSheet.Range("$A$1:$L$206").AutoFilter Field:=4, Criteria1:="<>Store" _
, Operator:=xlAnd, Criteria2:="<>Category"
ActiveSheet.Range("$A$1:$L$206").AutoFilter Field:=4, Criteria1:=sNm
With Sheets(sNm).AutoFilter.Range
On Error Resume Next
Set rDelete = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End With
''/// Remove the AutoFilter
.AutoFilterMode = False
.Range("A1").Select
End With
End Select
Next rCl
End With
MsgBox "Report completed", vbInformation, "Done"
clean_up:
ws.Columns(Columns.Count).ClearContents 'remove temporary list
rData.AutoFilter ''///switch off AutoFilter
Exit Sub
exit_Proc:
Application.ScreenUpdating = True
Resume clean_up
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
I would remove the "On Error Resume Next" statements and put
msgbox(Err.Description)
under the exit_Proc: handler to see what is going on.
I have this code which allows to a copy a customized range from any sheet and paste it to a fixed range on sheet 2. This code works but I need to implement paste link function in this code, so that if i want to make any changes to the data in DB it will auto update in sheet 2 as well. Here is the code I have done so far. Thank you in advance
Sub CustomizedInputFixedoutput()
Dim rng As Range, _
inp As Range, _
ws As Worksheet
Set inp = Selection
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled", vbInformation
Exit Sub
Else
rng.Parent.Activate
rng.Copy
Sheets("Sheet 2").Range("B2:N5").Value = rng.Value
End If
Application.CutCopyMode = False
End Sub
I felt sure this had to be a duplicate but searching [excel-vba] Paste Link found a few questions without any accepted answers and none that matched to OP desire to paste into a specific range.
Option Explicit
Sub CustomizedInputFixedoutput()
Dim CopyRng As Range
Dim PasteRng As Range
Dim Msg As String
Dim Response As VbMsgBoxResult
Set CopyRng = Selection
On Error Resume Next
Set PasteRng = Application.InputBox("Select a cell to copy to", Type:=8)
On Error GoTo 0
If Not PasteRng Is Nothing Then 'user clicked Cancel
If PasteRng.Count > 1 Then
'Get confirmation to paste to multi-cell range
Msg = "Are you sure you want to paste to " & PasteRng.Address & "?" _
& vbCrLf & vbCrLf _
& "Results may be unexpected if you proceed."
Response = MsgBox(Msg, vbQuestion + vbYesNo, "Confirm multi-cell paste range")
End If
If Response = vbYes Or PasteRng.Count = 1 Then
CopyRng.Copy
PasteRng.Parent.Activate
PasteRng.Activate
ActiveSheet.Paste Link:=True
Else
MsgBox "Cancelled", vbInformation
End If
Else
MsgBox "Cancelled", vbInformation
End If
Application.CutCopyMode = False
End Sub
Here you copy the range:
rng.Copy
And here you are assigning the value of B2:N5 the same value as rng.
Sheets("Sheet 2").Range("B2:N5").Value = rng.Value
The problem is that that code isn't pasting anything from the clipboard! You don't need to .Copy anything to assign cell values like this.
Use the Worksheet.Paste method instead of assigning the values (then the .Copy will serve its purpose), and set the optional parameter Links to True, like this:
Worksheets("Sheet 2").Range("B2:N5").Select
Worksheets("Sheet 2").Paste Links:=True
I have been trying to copy and paste from one sheet to another, whereby the cells should be copied with the pastelink feature, while making use of the input box to let the user enter the range where he wants to paste the copied data. The code works within the same sheet but not on a different one. Even if it works, it does not recognise the range I have entered in the input box. Instead, it recognises the cursor and pastes whereby the cursor is in the destination worksheet.
This is the code I used for the copying and pasting from sheet 1 to sheet 2. Is there any problem with the codes for which why it does not recognise the range I have entered in the input box?
Sub tryuserinput()
Dim rng As Range
Dim inp As Range
Selection.Interior.ColorIndex = 37
Set inp = Selection
Set rng = Application.InputBox("Copy to", Type:=8)
inp.Copy
rng.Select
Worksheets("Sheet2").Paste Link:=True
End Sub
Is this what you are trying?
Sub Sample()
Dim rng As Range, inp As Range
'~~> Check if what the user selected is a valid range
If TypeName(Selection) <> "Range" Then
MsgBox "Select a range first."
Exit Sub
Else
Set inp = Selection
inp.Interior.ColorIndex = 37
End If
Set rng = Application.InputBox("Copy to", Type:=8)
If Not rng Is Nothing Then
rng.Parent.Activate
rng.Select
inp.Copy
ActiveSheet.Paste Link:=True
End If
End Sub
Revised because...I didn't research. Just use this line of code after you choose the range in other sheet.
inp.Copy Destination:=ThisWorkbook.Sheets("Sheet2").Range(rng.Address)
I have a macro that copy/pastes a selection from one worksheet (Sheet1), to another worksheet (Notes). It works well. Now I want to first check if that worksheet exists. If it does not exist, I want to create it, then continue with the copy/pasting the selection.
When the "Notes" worksheet exists, the copy/paste works fine.
If the worksheet does not exist, it creates it, but the paste operation doesn't work. I don't get any errors. I have to rerun the macro and then the paste works (since the worksheet has already been created). Any ideas on what I missed?
Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"
'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
GoTo CopyPasteSelection
Else
Err.Clear
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
When you do the Add, the activesheet becomes the new worksheet and your previous Selection is lost...............you must "remember" it before the Add:
Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"
Dim RtoCopy As Range
Set RtoCopy = Selection
'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
GoTo CopyPasteSelection
Else
Err.Clear
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
RtoCopy.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Pay attention to the three lines referencing RtoCopy .
You have On Error Resume Next in your code. First time through it goes on its merry way. The second time through the Error check triggers the creation of the new tab.
On Error Resume Next is bad. Don't use it.
See this question for more information on solving your problem How to check whether certain sheets exist or not in Excel-VBA?
You should first activate and select the sheet and range to be copied. This works.
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Worksheets("Sheet1").Activate 'Activete "Sheet1"
Worksheets("Sheet1").Range("A1").Select 'Select the range to be copied
'Then copy selection
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
I suggest using Function for more re-usability:
A dirty and fast way:
Function isWorksheetValid(wsName As String)
ON Error Goto ErrHndl
Dim ws as Worksheet
Set ws = Sheets(wsName)
isWorksheetValid = True
Exit Function
ErrHndl:
isWorksheetValid = False
End Function
A correct but a bit slower way:
Function isWorksheetValid(wsName As String)
ON Error Goto ErrHndl
Dim ws as Worksheet
For Each ws in Sheets
If (UCASE(ws.Name) = UCASE(wsName)) Then
isWorksheetValid = True
Exit Function
End If
Next
ErrHndl:
isWorksheetValid = False
End Function
Now you need just use it like this:
If (isWorksheetValid(mySheetName) Then
' Add your code here
End If
I am trying to write a macro that will lock any cell greater than 0. When I run the code below it works but locks the 1st row where I have a drop down arrow that does sorting and number filters. Is there a way to add to this code so that the first row wont be locked?
Sub Test()
Dim Cell As Range
Dim MyPlage As Range
With ThisWorkbook.ActiveSheet
.Unprotect
.Cells.Locked = False
Set MyPlage = .Range("J2:AA1074")
For Each Cell In MyPlage
If Not IsError(Cell) Then
If Cell.Value > "0" Then
Cell.Locked = True
End If
End If
Next
.Protect
End With
End Sub
The most simplest was is to define your range which doesn't include the Top Row :)
Change
.Range("J2:AA1074")
to
.Range("J3:AA1074")
Also, Instead of looping through every cell in the range and checking if that cell has an error or not, you can directly use SpecialCells. For example (TRIED AND TESTED)
Sub Sample()
Dim Cell As Range, MyPlage As Range, FinalRange As Range
With ThisWorkbook.ActiveSheet
.Unprotect
.Cells.Locked = False
On Error Resume Next
Set MyPlage = .Range("J3:AA1074").SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not MyPlage Is Nothing Then
For Each Cell In MyPlage
If Cell.Value > 0 Then Cell.Locked = True
Next
End If
.Protect DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFiltering:=True, _
AllowSorting:=True
.EnableSelection = xlUnlockedCells
End With
End Sub
To ensure that Autofilter and Sorting works, specify it in .Protect as I have done above.
Before you run the above code, you also need to take one extra step.
Unprotect the worksheet if it is already protected
Under Review Tab, click on "Allow Users to Edit Ranges"
Add "New" range
Select the range you want allow users to sort
Screenshot
You can add following code to the Sheet module (change Range("J1:AA1") to the range with your autofilter):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.Intersect(Target, Range("J1:AA1")) Is Nothing Then
ActiveSheet.Protect
Else
ActiveSheet.Unprotect
End If
End Sub