Is it possible to stop following hyperlinks in Excel? I am very open to using macros and other methods. I found the following types of "solutions" after hours of searching but they would not work:
Disable all hyperlinks by using Selection.Hyperlinks.Delete
Have Excel turn off automatic hyperlink-ing
Have a dummy sheet with the hyperlinks that links to itself and use VBA for activation on follow
These do not work since I don't own the worksheet. My job is to automate reports/actions/calculations of my coworkers using user formulas or subs. The owner of the worksheet have lots of links included in the file which they would wish to keep. I cannot just arbitrarily remove their links. But troubleshooting and programming for me is difficult since I sometimes (not often, I usually use keyboard to navigate, but sometimes) accidentally click a link and there'll be popups and all that junk. I also cannot create a dummy sheet, since the worksheet contains some 10,000 lines of data, I'm afraid it would inflate the file size. Any help would be appreciated! Thanks!
I assume you want to temporarily disable the hyperlinks while you're working on the file, and then re-enable them when you've finished. One possible solution would be to store them in a seperate, temporary sheet.
Sub DisableLinks()
Dim ws As Worksheet
Dim ts As Worksheet
Set ts = ActiveSheet
Set ws = Worksheets.Add(after:=ts)
Dim hylink As Hyperlink
Dim destlink As Hyperlink
For Each hylink In ts.Hyperlinks
If hylink.Range.Value <> "" Then
ws.Range(hylink.Range.Address) = hylink.Range.Value
If hylink.SubAddress = "" Then
Set destlink = ws.Hyperlinks.Add(anchor:=ws.Range(hylink.Range.Address), Address:=hylink.Address, TextToDisplay:=hylink.TextToDisplay)
Else
ws.Hyperlinks.Add anchor:=ws.Range(hylink.Range.Address), Address:=hylink.Address, SubAddress:=hylink.SubAddress, TextToDisplay:=hylink.TextToDisplay
End If
hylink.Delete
End If
Next hylink
ws.Visible = xlVeryHidden
End Sub
Sub RestoreLinks()
Dim ws As Worksheet
Dim ts As Worksheet
Set ts = ActiveSheet
Set ws = Worksheets(ts.Index + 1)
ws.Visible = xlSheetVisible
Dim hylink As Hyperlink
For Each hylink In ws.Hyperlinks
If hylink.Range.Value <> "" Then
If hylink.SubAddress = "" Then
ts.Hyperlinks.Add anchor:=ts.Range(hylink.Range.Address), Address:=hylink.Address, TextToDisplay:=hylink.TextToDisplay
Else
ts.Hyperlinks.Add anchor:=ts.Range(hylink.Range.Address), Address:=hylink.Address, SubAddress:=hylink.SubAddress, TextToDisplay:=hylink.TextToDisplay
End If
hylink.Delete
End If
Next hylink
ws.Delete
End Sub
This will remove the hyperlink from the selection you have selected.
Sub removelinks()
Dim rng As Range
For Each r In Selection
rng.Hyperlinks.Delete
Next
End Sub
Related
Goal:
Replace the display text for any hyperlinks in an Excel sheet starting with www.google.com with Google while maintaining the original hyperlink URL and cell position.
I'm bashing together what I found online, like How To Change Multiple Hyperlink Paths At Once In Excel?.
I feel I'm close with:
Sub ReplaceHyperlinks()
Dim Ws As Worksheet
Dim xHyperlink As Hyperlink
Set Ws = Application.ActiveSheet
For Each xHyperlink In Ws.Hyperlinks
xHyperlink.TextToDisplay = Replace(xHyperlink.TextToDisplay, "www.google.com/*", "Google")
Next
End Sub
Use mid and find like
=MID(A1,5,FIND(".",A1,5)-5)
Edit:
So use hyperlink like
=HYPERLINK(B1,PROPER(B1))
Try this:
Sub ReplaceHyperlinks()
Dim Ws As Worksheet
Dim lnk As Hyperlink
Set Ws = Application.ActiveSheet
For Each lnk In Ws.Hyperlinks
If LCase(lnk.Address) Like "*google.com*" Then 'Google link ?
lnk.TextToDisplay = "Google"
End If
Next
End Sub
I have a workbook that crashes often. I suspect it's corrupted. So, I wrote the following code to copy it sheet by sheet to a new workbook. The size of the new workbook is now 40% less. Everything seems to work fine except the code doesn't copy tables. ListObjects doesn't seem to have a count property. So, it's not straight forward to detect the number of tables in a sheet.
How do I detect the existence, size, and location of tables? Once that info is known, I think it'd be quite easy to go to the target sheet and add tables. Thanks in advance for any help.
Sub copy_all()
'copy sheet by sheet from myworkbook.xlsb to the calling workbook
Dim rng As Range
Dim i As Integer
With Workbooks("myworkbook.xlsb")
For i = 1 To .Sheets.Count
Set rng = .Sheets(i).UsedRange
ThisWorkbook.Sheets(i).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Cells.Value = rng.Cells.Value
ThisWorkbook.Sheets(i).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Cells.Formula = rng.Cells.Formula
ThisWorkbook.Sheets(i).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Cells.ColumnWidth = rng.Cells.ColumnWidth
rng.Copy
ThisWorkbook.Sheets(i).Range("A1").PasteSpecial Paste:=xlPasteFormats
ThisWorkbook.Sheets(i).Name = .Sheets(i).Name
ThisWorkbook.Sheets(i).Tab.ColorIndex = .Sheets(i).Tab.ColorIndex
Next i
End With
End Sub
Try the next code, to find the ListObjects and their range address, please:
Sub testAllListObjects()
Dim T As ListObject, sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
If sh.ListObjects.Count > 0 Then
For Each T In sh.ListObjects
Debug.Print sh.Name, T.Name, T.Range.address
Next
End If
Next
End Sub
I am using an excel Workbook for programtical generation. Once the workbook is created few of the sheets are having required data and few are blank with default templates only.
I need to delete all sheets having default templates (means no data). I can check specific cell to identify this however need to know how to check for all sheets and then delete sheets one by one.
I am having this piece of code:
Sub TestCellA1()
'Test if the value is cell D22 is blank/empty
If IsEmpty(Range("D22").Value) = True Then
MsgBox "Cell A1 is empty"
End If
End Sub
Try this:
Sub DeleteEmptySheets()
Dim i As Long, ws As Worksheet
' we don't want alerts about confirmation of deleting of worksheet
Application.DisplayAlerts = False
For i = Worksheets.Count To 1 Step -1
Set ws = Worksheets(i)
' check if cell D22 is empty
If IsEmpty(ws.Range("D22")) Then
Sheets(i).Delete
End If
Next
' turn alerts back on
Application.DisplayAlerts = True
End Sub
An alternative implementation using For-Each:
Sub deleteSheets()
Dim wb As Workbook
Dim sht As Worksheet
Set wb = Workbooks("Name of your Workbook")
'Set wb = ThisWorkbook You can use this if the code is in the workbook you want to work with
Application.DisplayAlerts = False 'skip the warning message, the sheets will be deleted without confirmation by the user.
For Each sht In wb.Worksheets
If IsEmpty(sht.Range("D22")) And wb.Worksheets.Count > 1 then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
End Sub
This mainly serves as a demonstration pf how you can easily loop through worksheets.
As suggested in the comments below by #Darren Bartrup-Cook , the logic according to which the sheets are deleted can and should be modified to not only suit your purposes but to also include safeguards.
Making sure there's always at least one worksheet in the workbook is one of them. This can be ensured in a multitude of ways. I updated my answer to implement one these.
I have a workbook that the workbook formatting is changed regularly, however once changed (maybe weekly or monthly) then going forward until it is changed again a macro needs to replicate that format. Changing the VBA to account for the new formatting each time is very time consuming. Is it possible to format a workbook and then copy the formatting easily to VBA (after the fact not like a macro record) for future use?
In the past I have since used a hidden sheet within the workbook where the macro runs and I essentially copy/paste that into the sheet I am working with. This works but has the downside of when making changes I first need to copy data over to the "template" sheet to ensure everything is correctly aligned with new data.
Possibly some kind of macro that iterates through all cells of a range and outputs to the immediate window the VBA code needed to re-create the formatting?
Basically any ideas will help :)
There are so many formatting options that simply storing them as separate options will take far more space than just a duplicate template sheet. Just run the first code to update your template, and the second to copy it back:
option Explicit
Const TemplatesheetName = "mytemplate"
Sub CopyFormatting
dim ws as worksheet
dim source as worksheet
set source = activesheet
for each ws in worksheets
if ws.name = templatesheetname then
exit for
end if
next ws
if ws is nothing then
set ws = worksheets.add
ws.name = templatesheetname
end if
ws.usedrange.clearformats
source.usedrange.copy
ws.range("a1").pastespecial xlpasteformats
ws.visible = xlveryhidden
end sub
Sub BringBackFormats
dim ws as worksheet
for each ws in worksheets
if ws.name = templatesheetname then
exit for
end if
next ws
if ws is nothing then
msgbox "No template found",vbokonly,"Unabl;e to run"
else
ws.cells.copy
activesheet.range("a1").pastespecial xlpasteformats
end if
exit sub
(written on my phone, can't check the code, there may be typos)
I am working on a macro that will cycle through all of the sheets in the active workbook and will then clear a certain part of a particular worksheet, based on whether one of the relevant keywords is contained in the worksheet name. In each case the worksheet name will be different, but any I want to clear will contain one of the key words below.
I have set up a separate macro to clear the range of cells in each case. If the Worksheet name does not contain any of the keywords, I want the macro to move onto the next worksheet.
My ultimate aim is to be able to apply this to numerous different workbooks, as the project I am working on is split by region, with a separate Excel file per region.
The code I have been trying is below. There are no errors appearing when I run the code, the code does not seem to run either, in fact nothing at all happens!
Any guidance or advice would be greatly appreciated.
Sub Loop_Customer_Sheets()
Dim ws As Integer
Dim i As Integer
ws = ActiveWorkbook.Worksheets.Count
For i = 1 To ws
If ActiveSheet.Name Like "*ABC*" Then
Call ABCInfoClear
ElseIf ActiveSheet.Name Like "*DEF*" Then
Call DEFInfoClear
ElseIf ActiveSheet.Name Like "*GHI*" Then
Call GHIInfoClear
Else:
End If
Next i
End Sub
"Nothing at all happens" - fixing the issue with your code:
Your issue is that you are looping through the number of sheets, but you are only checking the ActiveSheet, which never changes! Replace your code with
ws = ActiveWorkbook.Worksheets.Count
For i = 1 To ws
With ActiveWorkbook.WorkSheets(i)
If .Name Like "*ABC*" Then
ABCInfoClear
ElseIf .Name Like "*DEF*" Then
DEFInfoClear
ElseIf ActiveSheet.Name Like "*GHI*" Then
GHIInfoClear
End If
End With
Next i
Note: you don't need the Call keyword, you can just call subs as presented above.
Alternative solutions
A better option than having numerous macros might be to create a generic sub like
Sub ClearRangeInSheet(rangeAddress As String, sh As WorkSheet)
Dim myRange As Range
Set myRange = sh.Range(rangeAddress)
myRange.ClearContents
' Any other cell clearing code e.g. for formatting here
End Sub
Then call in the loop
Dim wsCount as Long
wsCount = ActiveWorkbook.WorkSheets.Count
For i = 1 to wsCount
With ActiveWorkbook
If .WorkSheets(i).Name Like "*ABC*" Then
' Always pass ".WorkSheets(i)", but change the range address as needed
ClearRangeInSheet("A1:A20", .WorkSheets(i))
ElseIf ' Other worksheet name conditions ...
End If
End With
Next I
As suggested in the comments, you could ditch indexing the sheets, and just loop through the sheet objects themselves:
Dim wksht as WorkSheet
For Each wksht In ActiveWorkbook.WorkSheets
If wksht.Name Like "*ABC*" Then
' Always pass wksht but change the range address as needed
ClearRangeInSheet("A1:A20", wksht)
ElseIf ' Other worksheet name conditions ...
End If
Next wksht