I want to create macro which when run, pastes the link contained in clipboard to the current cell as a hyperlink. I tried with the record macro the following code was generated which I modified a little:
Sub Macro1()
'
' Macro1 Macro
'
'
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="abc.com" _
, TextToDisplay:="Link"
End Sub
Here, instead of abc.com it should be something like "paste text in keyboard".
According to the #DanL comment, here is the code you need :
Sub Macro1()
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=GetClipboardText() _
, TextToDisplay:="Link"
End Sub
Function GetClipBoardText() as String
Dim DataObj As MSForms.DataObject
Set DataObj = New MsForms.DataObject '<~~ Amended as per jp's suggestion
On Error GoTo Whoa
'~~> Get data from the clipboard.
DataObj.GetFromClipboard
'~~> Get clipboard contents
GetClipBoardText = DataObj.GetText(1)
Exit Sub
Whoa:
If Err <> 0 Then MsgBox "Data on clipboard is not text or is empty"
End Sub
Related
I want to copy a range of cell (values only/ text) to the clipboard so the user does not have to do a paste special values only when they paste them into another spreadsheet.
Here is what I have so far:
Private Sub CommandButton1_Click()
With New DataObject
.SetText Range("A32:Q32").Text
.PutInClipboard
End With
'Range("A32:Q32").Copy
End Sub
This gives me a runtime error
94 Invalid use of Null
If I just use the commented out code Range.("A32:Q32").Copy it copies the formulas and unless the user does the special paste they get all kinds of reference errors.
It's a bit convoluted, but get text > clear clipboard > put text back :
[A32:Q32].Copy
With New DataObject
.GetFromClipboard
s = .GetText
.Clear
.SetText s
.PutInClipboard
End With
Range.Text returns Null when the individual cell texts in the range are different.
I don’t know dataobject, so I propose a workaround by having the user select the destination cell, too
Private Sub CommandButton1_Click()
Dim userRng As Range
With ActiveSheet 'reference currently active sheet, before the user could change it via inputbox
Set userRange = GetUserRange()
If Not userRange Is Nothing Then ' if the user chose a valid range
With .Range("A32:Q32")
userRange.Resize(.Rows.Count, .Columns.Count).Value =.Value ' paste values only
End With
End If
End With
End Sub
Function GetUserRange() As Range
' adapted from http://spreadsheetpage.com/index.php/tip/pausing_a_macro_to_get_a_user_selected_range/
Prompt = "Select a cell for the output."
Title = "Select a cell"
' Display the Input Box
On Error Resume Next
Set GetUserRange = Application.InputBox( _
Prompt:=Prompt, _
Title:=Title, _
Default:=ActiveCell.Address, _
Type:=8) 'Range selection
' Was the Input Box canceled?
If GetUserRange Is Nothing Then MsgBox “Canceled!”
End Function
I would like to copy one specific sheet in MS Excel to a new file. The following Macro does the job, but the problem is that the copy always links the cells to the original file. Is there a way to insert only the values of this sheet without the links?
Sub Copy_sheet()
ThisWorkbook.Sheets("Overview").Copy
ActiveWorkbook.SaveAs "C:\testfolder\testfile.xlsx", FileFormat:=51
End Sub
Thank you!
Add the following to your code before the End sub:
With ThisWorkbook.Worksheets("Overview").UsedRange
.Value = .Value
End With
It would change the formulas to values. If you want to do it for the whole workbook, this is the way to go:
Public Sub CopyJustData()
Dim lngCount As Long
For lngCount = 1 To Worksheets.Count
With Worksheets(lngCount).UsedRange
.Value = .Value
End With
Next lngCount
End Sub
One way is this.
Sub Copy_sheet()
Dim wbNew As Workbook
ThisWorkbook.Sheets("Overview").Copy
Set wbNew = ActiveWorkbook
With wbNew
With .Worksheets(1).UsedRange
.Value = .Value
End With
.SaveAs "C:\testfolder\testfile.xlsx"
End With
End Sub
Sub SaveCopy
ThisWorkbook.Sheets("your sheet name").Select
ActiveSheet.Copy
ActiveSheet.SaveAs FileName:="your path to save "& ".xlsx" 'xlsx or your other
BreakLinks '
End Sub
Sub BreakLinks()
On Error Resume Next
Dim vLinks As Variant
Dim lLink As Long
' Define variable as an Excel link type.
vLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
If vLinks = vbNullString Then Exit Sub
' Break all links in the active workbook.
For lLink = LBound(vLinks) To UBound(vLinks)
ActiveWorkbook.BreakLink _
Name:=vLinks(lLink), _
Type:=xlLinkTypeExcelLinks
Next lLink
End Sub
My problem is that I need to execute a Macro only on the marked cell.
The Macro needs to do the following:
Selected cell is formated always for example as 20*20*20 always 3 numbers.
It should copy this text add a " = " before the numbers and output it on another column.
The Code I got until now is:
Sub First()
'
' First Makro
'
'
Selection.Copy
Range("G11").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=20*20*20"
Range("G12").Select
End Sub
I have got this code with the record Macro function
Thanks very much
#SiddharthRout exactly but i need to be able to select it by hand because sometimes it's for example E17 sometimes e33 and output always need's to be G Column in the Same Row
Is this what you are trying?
Sub Sample()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
'~~> Replace Sheet1 with the relevant sheet name
Set ws = wb.Sheets("Sheet1")
'~~> Check if what the user selected is a valid range
If TypeName(Selection) <> "Range" Then
MsgBox "Select a range first."
Exit Sub
End If
'~~> Check if the user has selected a single cell
If Selection.Cells.Count > 1 Then
MsgBox "Please select a single cell"
Exit Sub
End If
ws.Range("G" & Selection.Row).Formula = "=" & Selection.Value
End Sub
I'm looking for a VBA Macro to export data to a csv. I found this code
which after some tweaking does a great job. However, when copying from a range, Excel seems to ignore hidden columns while I want the CSV to contain all the columns. Has anyone discovered concise way to code this?
Here is the code I have so far:
Sub ExportListOrTable(Optional newBook As Boolean, Optional willNameSheet As Boolean, Optional asCSV As Boolean, Optional visibleOnly As Boolean)
'Sub CopyListOrTable2NewWorksheet()
'Works in Excel 2003 and Excel 2007. Only copies visible data.
'code source: https://msdn.microsoft.com/en-us/library/dd637097%28v=office.11%29.aspx
'improved by: Tzvi
' - replaced new worksheet with new workbook
'params:
' newBook: To create a new new sheet in the current workbook or (default) in a new workbook
' willNameSheet: To offer the user to name the sheet or (default) leave the default names
' asCSV: not implemented - will always save as CSV
' visibleOnly: to filter out any hidden columns - default false
'TODO
' -add parameter list for following options:
' - if table was not selected, copy activesheet.usedRange
' - optional saveFileType
' -
Dim New_Ws As Worksheet
Dim ACell, Data As Range
Dim CCount As Long
Dim ActiveCellInTable As Boolean
Dim CopyFormats, retrySave As Variant
Dim sheetName, user, defaultFileName, fileSaveName As String
Dim userChoice As Boolean
'Check to see if the worksheet or workbook is protected. TODO this may not be necessary anymore
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro will not work when the workbook or worksheet is write-protected."
Exit Sub
End If
'Set a reference to the ActiveCell. You can always use ACell to
'point to this cell, no matter where you are in the workbook.
Set ACell = activeCell
'Test to see if ACell is in a table or list. Note that by using ACell.ListObject, you
'do not need to know the name of the table to work with it.
On Error Resume Next
ActiveCellInTable = (ACell.ListObject.Name <> "")
On Error GoTo 0
'TODO here we will select the fields to export
'If the cell is in a list or table run the code.
If ActiveCellInTable = True Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If visibleOnly = True Then
'Test if there are more than 8192 separate areas. Excel only supports
'a maximum of 8,192 non-contiguous areas through VBA macros and manual.
On Error Resume Next
With ACell.ListObject.ListColumns(1).Range 'TODO remove this "with"
CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
End With
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 individual areas, so it is not possible to " & _
"copy the visible data to a new worksheet. Tip: Sort your " & _
"data before you apply the filter and try this macro again.", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
Else
'Copy the visible cells.
ACell.ListObject.Range.Copy
End If
Else
'The user indicated he wants to copy hidden columns too.
'**********************************************************
'HOW DO I PROPERLY IMPLEMENT THIS PART?
'**********************************************************
MsgBox ("You wanted to copy hidden columns too?")
ActiveSheet.UsedRange.Copy
End If
Else
' MsgBox "Select a cell in your list or table before you run the macro.", _
' vbOKOnly, "Copy to new worksheet"
userChoice = MsgBox("A Table/Table protion is not selected. Do you want to export the entire page?", vbYesNo)
If userChoice = False Then Exit Sub
ActiveSheet.UsedRange.Copy
'Exit Sub
End If
'Add a new Worksheet/WorkBook.
If newBook = False Then
Set New_Ws = Worksheets.Add(after:=Sheets(ActiveSheet.Index))
Else
Set New_Ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
End If
'Prompt the user for the worksheet name.
If willNameSheet = True Then
sheetName = InputBox("What is the name of the new worksheet?", _
"Name the New Sheet")
On Error Resume Next
New_Ws.Name = sheetName
If Err.Number > 0 Then
MsgBox "Change the name of sheet : " & New_Ws.Name & _
" manually after the macro is ready. The sheet name" & _
" you typed in already exists or you use characters" & _
" that are not allowed in a sheet name."
Err.Clear
End If
On Error GoTo 0
End If
'Paste the data into the new worksheet.
With New_Ws.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
.Select
Application.CutCopyMode = False
End With
Application.ScreenUpdating = False
'If you did not create a table, you have the option to copy the formats.
If ActiveCellInTable = False Then
Application.Goto ACell
CopyFormats = MsgBox("Do you also want to copy the Formatting?", _
vbOKCancel + vbExclamation, "Copy to new worksheet")
If CopyFormats = vbOK Then
ACell.ListObject.Range.Copy
With New_Ws.Range("A1")
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
'Select the new worksheet if it is not active.
Application.Goto New_Ws.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Now we're ready to save our new file as excel format
defaultFileName = ActiveWorkbook.Name
user = Environ("userprofile")
'marker getfilename: to return to if we need to look for a new filename
getfilename:
ChDir user & "\Desktop"
fileSaveName = Application.GetSaveAsFilename(defaultFileName & ".csv", "Comma Delimited Format (*.csv), *.csv")
If fileSaveName <> "False" Then
'error handling for 'file already exists and the user clicks 'no'
On Error Resume Next
ActiveWorkbook.SaveAs fileName:=fileSaveName, FileFormat:=xlCSV, ReadOnlyRecommended:=True, CreateBackup:=False, ConflictResolution:=xlUserResolution
If Err.Number = 1004 Then
'Offer user two options: To try a different filename or cancel the entire export
retrySave = MsgBox(Err.Description, vbRetryCancel, "Error creating file")
If retrySave = vbRetry Then
GoTo getfilename
Else
GoTo cancelprocedure
End If
End If
On Error GoTo 0
Else
GoTo cancelprocedure
End If
Exit Sub
cancelprocedure:
ActiveWorkbook.Close saveChanges:=False
Exit Sub
End Sub
Update:
In response to shagans concern. The parameter list on line one is intended to be set by another Macro as such:
Sub ExportVisibleAsCSV
Call ExportListOrTable(newBook:=True, willNameSheet:=False, asCSV:=True, visibleOnly:=True)
End Sub
Updating now that example code is available:
Ok looking at the code you posted, I see a bool named visibleOnly but I don't see where it gets set. Your ability for the logic to reach UsedRange.Copy entirely depends on that being set to false. The comment above ACell.ListObject.Range.Copy indicates that if you reach that statement you are only copying visible cells. In order to copy the hidden cells, visibleOnly would need to be set to false (bypassing the rest of the CCount stuff). So I would be interested in knowing how that bool is set and checking to see what its value is set to when you are running your code.
Update 2:
You need to set the value of your visibleOnly boolean somehow.
here's some code I edited that creates a message box that allows the user to say "yes" or "no" to "do you want to copy hidden data too?" that answer will dictate the value of visibleOnly which in turn dictates which flow they enter.
In addition to that, your assumption that ACell.ListObject.Range.Copy would only copy visible cells appears to have been incorrect. Instead that is being replaced with the specialcell type for visible cells.
Finally, vbYesNo does not actually return a boolean value. Instead it returns vbYes or vbNo which are vb type enumerators (value 6 and 7 respectively). So setting a bool to the value of a vbYesNo will always return True (as a value exists and essentially it just evaluates iferror).
So I changed that bit as well so it now properly checks the Yes/No condition on your userchoice (which is no longer a bool).
here's the code:
Dim ACell, Data As Range
Dim CCount As Long
Dim ActiveCellInTable As Boolean
Dim CopyFormats, retrySave As Variant
Dim sheetName, user, defaultFileName, fileSaveName As String
'Check to see if the worksheet or workbook is protected. TODO this may not be necessary anymore
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro will not work when the workbook or worksheet is write-protected."
Exit Sub
End If
'Set a reference to the ActiveCell. You can always use ACell to
'point to this cell, no matter where you are in the workbook.
Set ACell = ActiveCell
'Test to see if ACell is in a table or list. Note that by using ACell.ListObject, you
'do not need to know the name of the table to work with it.
On Error Resume Next
ActiveCellInTable = (ACell.ListObject.Name <> "")
On Error GoTo 0
'TODO here we will select the fields to export
'If the cell is in a list or table run the code.
If ActiveCellInTable = True Then
CopyHidden = MsgBox("Would you like to copy hidden data also?", vbYesNo, "Copy Hidden Data?")
If CopyHidden = vbYes Then
visibleOnly = False
ElseIf CopyHidden = vbNo Then
visibleOnly = True
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If visibleOnly = True Then
'Test if there are more than 8192 separate areas. Excel only supports
'a maximum of 8,192 non-contiguous areas through VBA macros and manual.
On Error Resume Next
With ACell.ListObject.ListColumns(1).Range 'TODO remove this "with"
CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
End With
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 individual areas, so it is not possible to " & _
"copy the visible data to a new worksheet. Tip: Sort your " & _
"data before you apply the filter and try this macro again.", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
Else
'Copy the visible cells.
ACell.ListObject.Range.SpecialCells(xlCellTypeVisible).Copy
' Only visible cells within the table are now in clipboard
End If
Else
'The user indicated he wants to copy hidden columns too.
MsgBox ("You wanted to copy hidden columns too?")
ACell.ListObject.Range.Copy
' All table data cells including hidden are now in clipboard
End If
Else
' MsgBox "Select a cell in your list or table before you run the macro.", _
' vbOKOnly, "Copy to new worksheet"
userChoice = MsgBox("A Table/Table protion is not selected. Do you want to export the entire page?", vbYesNo)
If userChoice = vbNo Then Exit Sub
ActiveSheet.UsedRange.Copy
'Entire sheet range is now in clipboard (this is not always accurate)
'Exit Sub
End If
Assign the Value of the range to your target range instead of using the .Copy method:
Sub ExportCSV(source As Range, filename As String)
Dim temp As Workbook
Set temp = Application.Workbooks.Add
Dim sheet As Worksheet
Set sheet = temp.Worksheets(1)
Dim target As Range
'Size the target range to the same dimension as the source range.
Set target = sheet.Range(sheet.Cells(1, 1), _
sheet.Cells(source.Rows.Count, source.Columns.Count))
target.Value = source.Value
temp.SaveAs filename, xlCSV
temp.Close False
End Sub
This also has the benefit of not nuking whatever the user might have on the clipboard.
i have a program that copies a range of cells and the needs to paste the contents into a new workbook that is created in code. i can copy the data but somehow the clipboard loses its data whenever i change workbooks to the new one created. i considered copying the cells to an array and then just copying the array to the new workbook but i wont know the size of the array at coding time this varies almost every time the macro runs.
how do i then keep the data on the clipboard while i change the active workbook?
cell = "k7: l" & row
Worksheets(1).Range(cell).Select
Selection.Copy
relpath = ThisWorkbook.Path & "\" & "DispersionList.xls"
If Dir(relpath) <> "" Then
Application.Workbooks.Open (relpath)
Workbooks("DispersionList.xls").Activate
Else
Call createWorkbook
End If
Worksheets(1).Cells(7, 14).Select
Selection.PasteSpecial
End Sub
if i run through the code line by line and check the clipboard it loses its contents at the workbooks.open line
There are a few actions in Excel/VBA that will void the selection/clipboard, e.g. changing any window/display settings. Thus, I suspect there is some event being called when you change the worksheet/workbook.
You can either debug it and while stepping through the code figure out, when the selection is voided and avoid this statement (if possible).
Alternatively, use subStoreClipboard and subRestoreClipboard from below code in your event code. To use the code, insert it in a new module in your worksheet - and also insert a new (hidden) worksheet which is named "ws_Temp" in VBA.
Private mIntCutCopyMode As XlCutCopyMode
Private mRngClipboard As Range
Public Sub subStoreClipboard()
On Error GoTo ErrorHandler
Dim wsActiveSource As Worksheet, wsActiveTarget As Worksheet
Dim strClipboardRange As String
mIntCutCopyMode = Application.CutCopyMode
If Not fctBlnIsExcelClipboard Then Exit Sub
Application.EnableEvents = False
'Paste data as link
Set wsActiveTarget = ActiveSheet
Set wsActiveSource = ThisWorkbook.ActiveSheet
With ws_Temp
.Visible = xlSheetVisible
.Activate
.Cells(3, 1).Select
On Error Resume Next
.Paste Link:=True
If Err.Number Then
Err.Clear
GoTo Finalize
End If
On Error GoTo ErrorHandler
End With
'Extract link from pasted formula and clear range
With Selection
strClipboardRange = Mid(.Cells(1, 1).Formula, 2)
If .Rows.Count > 1 Or .Columns.Count > 1 Then
strClipboardRange = strClipboardRange & ":" & _
Mid(.Cells(.Rows.Count, .Columns.Count).Formula, 2)
End If
Set mRngClipboard = Range(strClipboardRange)
.Clear
End With
Finalize:
wsActiveSource.Activate
wsActiveTarget.Parent.Activate
wsActiveTarget.Activate
ws_Temp.Visible = xlSheetVeryHidden
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Err.Clear
Resume Finalize
End Sub
Public Sub subRestoreClipboard()
Select Case mIntCutCopyMode
Case 0:
Case xlCopy: mRngClipboard.Copy
Case xlCut: mRngClipboard.Cut
End Select
End Sub
Private Function fctBlnIsExcelClipboard() As Boolean
Dim var As Variant
fctBlnIsExcelClipboard = False
'check if clipboard is in use
If mIntCutCopyMode = 0 Then Exit Function
'check if Excel data is in clipboard
For Each var In Application.ClipboardFormats
If var = xlClipboardFormatCSV Then
fctBlnIsExcelClipboard = True
Exit For
End If
Next var
End Function