I have VBA code found on the internet. It creates sheets using my template based on a list in my summary sheet.
I want it to make a hyperlink to the sheet in my list.
Mal=Template
Sammendrag=Summary
Here it is:
Sub CreateSheetsFromAList() ' Example Add Worksheets with Unique Names
Dim MyRange As Range, i As Long
Dim ShtName As String
Application.ScreenUpdating = 0
With Sheets("Sammendrag")
Set MyRange = .Range("B10:B69" & .Range("a" & .Rows.Count).End(xlUp).Row)
End With
Sheets("Mal").Visible = True
With MyRange
For i = 1 To .Rows.Count
ShtName = Trim(.Cells(i, 1).Value)
If Len(ShtName) Then
If Not WorksheetExists(ShtName) Then
Sheets("Mal").Copy After:=Sheets(Sheets.Count)
ActiveSheet.name = ShtName
End If
End If
Next
End With
Sheets("Mal").Visible = False
Application.ScreenUpdating = 1
End Sub
With this code you can add a hyperlink:
.Cells(i, 1).Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", SubAddress:="'" & Worksheets(SHtName).Name & "'!A1", TextToDisplay:=Worksheets(SHtName).Name
On click you will jump to Cell A1 of the Sheet.
Related
Have data on columnA and trying to filter data using keywords. member of groups is in the down adjacent cells. starting with +.
Sub Mymacro()
Range("B2:B2000").Clear
For Each Cell In Sheets(1).Range("A1:A2000")
matchrow = Cell.Row
Find = "*" + Worksheets("Sheet1").Range("B1") + "*"
If Cell.Value Like Find Then
Cell.Offset(0, 1).Value = Cell.Offset(0, 0).Value
End If
Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$1" Then
Call Mymacro
End If
End Sub
The above code is extracting text correctly with the green text but the expecting item is still missing which is just highlighted using the red text. tried a couple of options but no luck.
Referencing a worksheet with its index number as Sheets(1) is not advisable. It refers to the first sheet in the workbook including a chart sheet. If the sheet referred is moved from its first position in the workbook then the macro will run in the new worksheet at the first position. If the first sheet is a chart sheet, the macro will cause error. Hence, please replace below Sheets(1) reference with Sheet name like Sheets("Sheet1") or VBA Project worksheet name as Sheet1
Option Explicit
Sub Mymacro()
Dim fltArea As Range, fltAreas As Range, fltAreasGroup As Range
Dim lastRow As Long
lastRow = Sheets(1).Range("A1048576").End(xlUp).Row
Sheets(1).Range("B2:B" & lastRow).Clear
Sheets(1).Range("$A$1:$A$" & lastRow).AutoFilter Field:=1, Criteria1:="=+*", _
Operator:=xlAnd
Set fltAreasGroup = Sheets(1).Range("$A$2:$A$" & lastRow).SpecialCells(xlCellTypeVisible)
Sheets(1).AutoFilterMode = False
For Each fltAreas In fltAreasGroup.Areas
Set fltArea = fltAreas.Offset(-1).Resize(fltAreas.Rows.Count + 1, 1)
If InStr(1, Join(Application.Transpose(Application.Index(fltArea.Value, 0, 1)), ","), _
Sheets(1).Range("B1").Value, vbTextCompare) > 0 Then
fltArea.Offset(, 1).Value = fltArea.Value
End If
Next
Sheets(1).Range("$A$1:$B$" & lastRow).AutoFilter Field:=1, Criteria1:="=*" & Sheets(1).Range("B1").Value & "*", _
Operator:=xlAnd
Sheets(1).Range("$A$1:$B$" & lastRow).AutoFilter Field:=2, Criteria1:="="
Set fltAreas = Sheets(1).Range("$A$2:$A$" & lastRow).SpecialCells(xlCellTypeVisible)
Sheets(1).AutoFilterMode = False
For Each fltArea In fltAreas
fltArea.Offset(, 1).Value = fltArea.Value
Next
End Sub
I have a good basic script that returns me the sheet name of each sheet in the workbook, but now I'd like to add the contents of cell A1, A2, A3, and A4 into columns B, C, D, and E and add a header row with "Link, Variable, Definition, Calculation, Notes" in columns A, B, C, D. The existing hyperlink will be in column A.
It will need to loop through the entire workbook, and if possible skip adding a link to the table of contents page. Here is a basic script I currently use (borrowed from Extend Office) -
'updateby Extendoffice 20180413
Dim xAlerts As Boolean
Dim I As Long
Dim xShtIndex As Worksheet
Dim xSht As Variant
xAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Table of contents").Delete
On Error GoTo 0
Set xShtIndex = Sheets.Add(Sheets(1))
xShtIndex.Name = "Table of contents"
I = 1
Cells(1, 1).Value = "Table of contents"
For Each xSht In ThisWorkbook.Sheets
If xSht.Name <> "Table of contents" Then
I = I + 1
xShtIndex.Hyperlinks.Add Cells(I, 1), "", "'" & xSht.Name & "'!A1", , xSht.Name
End If
Next
Application.DisplayAlerts = xAlerts
End Sub
Not sure if this does exactly what you want, there is some gaps in the explanation in regards how you want to handle the link fucntion. Since you mention the code "works" but you want some added function, and you dont want links on the "table of contents" but it doesn't do that now either?
anyway give this a go...
Private Sub CommandButton1_Click()
Dim xAlerts As Boolean
Dim I As Long
Dim xShtIndex As Worksheet
Dim Table As Worksheet
Dim xSht As Variant
xAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Table of contents").Delete
On Error GoTo 0
Set xShtIndex = Sheets.Add(Sheets(1))
xShtIndex.Name = "Table of contents"
Set Table = Worksheets("Table of contents")
I = 2
targetcolumn = 1
'Cells(1, 1).Value = "Table of contents"
'Disabled this because i'm not sure if this code should be here?
For Each xSht In ThisWorkbook.Sheets
With xSht
If xSht.Name = "Table of contents" Then
.Cells(1, 1).Value = "Table of contents"
.Range("A1").Value = "Link"
.Range("B1").Value = "Variable"
.Range("C1").Value = "Definition"
.Range("D1").Value = "Calculation"
.Range("E1").Value = "Notes"
End If
If xSht.Name <> "Table of contents" Then
lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim copyrng As Range
Set copyrng = .Range("A1:A" & lrow)
copycount = 2 'skipping one because with 1 it would write to row 1 which is where the headers are
For Each cell In copyrng
Table.Cells(targetcolumn, copycount).Value = cell.Value
copycount = copycount + 1
Next
Table.Hyperlinks.Add Table.Cells(I, 1), "", "'" & xSht.Name & "'!A1", , xSht.Name
I = I + 1
End If
End With
targetcolumn = targetcolumn + 1
Next
Application.DisplayAlerts = xAlerts
End Sub
I am attempting to loop through data in a sheet and split them on a comma, when I run the script I get a Run Time Error '1004' Application-Defined or Object defined error.
However, When I step into the script to debug and run it step by step it works perfectly. I was wondering if anyone has seen this and could help me in fixing it.
Sub PopulatePayrollForm()
Dim s As String: s = "Payout Review"
If DoesSheetExists(s) Then
Dim BottomRow As Long
Dim c As Range
Dim splitv() As String
Sheets("Pay Form").Range("A6:AR1000").ClearContents
'Copy to another sheet, Split Columns, Copy and paste full name into 2 cells
Worksheets("Payout Review").Range("A2:A1000").Copy Worksheets("Pay Form").Range("AQ6:AQ1006")
BottomRow = Worksheets("Pay Form").Cells(Rows.Count, "AQ").End(xlUp).Row
Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow).Activate
For Each c In Selection
splitv = Split(c.Value, ",")
If UBound(splitv) > 0 Then
c.Offset(0, -1).Value = splitv(1)
c.Offset(0, -1).Value = c.Offset(0, -1).Value
c.Value = splitv(0)
End If
Next c
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Copy Worksheets("Pay Form").Range("C6:C" & BottomRow)
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Clear
'Copy and paste Employee Id, Payout AMount, Date Range
Worksheets("Payout Review").Range("B2:B1000").Copy Worksheets("Pay Form").Range("A6:A" & BottomRow)
Worksheets("Payout Review").Range("AB2:AB1000").Copy
Sheets("Pay Form").Range("B6:B" & BottomRow).PasteSpecial xlPasteValues
Worksheets("Payout Review").Range("AD1").Copy Worksheets("Pay Form").Range("J6:J" & BottomRow)
Worksheets("Payout Review").Range("AE1").Copy Worksheets("Pay Form").Range("K6:K" & BottomRow)
Sheets("Pay Form").Visible = True
Else
MsgBox "Data Does not exist"
End If
End Sub
Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
The problem is the use of Selection (and Activate):
For Each c In Selection
Just use the Range in question:
For Each c In Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow)
I recommend reading this for a comprehensive discussion of how to avoid Select.
I have an Excel sheet with 5 tabs, column A in each is where I want a clickable cell.
When that cell is clicked, I want it to cut the 4 cells to the right of it on the same row and paste it on the next tab.
Clicking A1 would cut B1, C1, D1, E1 and paste it on the next tab, on the next empty row.
Same with the next tab until that row has made it to the final tab.
All the data is on the first sheet, all the others are empty.
Once I click on the first sheet I want it to move to the next one, then when I click it on the next one I want it to move to the third one.
So far I have code that creates hyperlinks on the cells I highlight, but it displays (sheet name! cell number). I want to display a specific txt instead, like (complete) or (received). The display varies for each tab.
The code I have in the first sheet moves the cut row to the second sheet.
I tried pasting that code in the next sheet to move it to the third sheet but I get an error.
Code in module
Sub HyperActive()
Dim nm As String
nm = ActiveSheet.Name & "!"
For Each r In Selection
t = r.Text
addy = nm & r.Address(0, 0)
ActiveSheet.Hyperlinks.Add Anchor:=r, Address:="", SubAddress:= _
addy, TextToDisplay:=r.Text
Next r
End Sub
Code in sheet
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim r As Range
Set r = Range(Target.SubAddress)
r.Offset(0, 1).Resize(1, 4).Cut
Sheets("Wash Bay").Select
Worksheets("Wash Bay").Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End Sub
I'd suggest using the Workbook_SheetFollowHyperlink event here. This is the workbook-level event, as opposed to the worksheet-level Worksheet_FollowHyperlink event.
From the docs:
Occurs when you choose any hyperlink in Microsoft Excel...
Parameters
Sh : The Worksheet object that contains the hyperlink
Target: The Hyperlink object that represents the destination of the hyperlink
Add the following code to the ThisWorkbook module (not the sheet code module).
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
If Sh.Index = Me.Worksheets.Count Then Exit Sub ' Do nothing if `Sh` is the last worksheet
Dim nextWs As Worksheet
Set nextWs = Me.Worksheets(Sh.Index + 1)
With nextWs
Dim lastRow As Long
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With
Dim rng As Range
Set rng = Sh.Range(Target.SubAddress)
rng.Offset(, 1).Resize(1, 4).Cut Destination:=nextWs.Range("B" & lastRow + 1)
Application.CutCopyMode = False
End Sub
IMPORTANT NOTE: In its current state, this assumes that the workbook only has worksheets (no chart sheets, for example).
EDIT: You can use this revised code if the workbook contains other sheet types besides worksheets:
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Dim indx As Long
indx = GetWorksheetIndex(Sh)
If indx = Me.Worksheets.Count Then Exit Sub
Dim rng As Range
Set rng = Sh.Range(Target.SubAddress)
Dim nextWs As Worksheet
Set nextWs = Me.Worksheets(indx + 1)
With nextWs
Dim lastRow As Long
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With
rng.Offset(, 1).Resize(1, 4).Cut Destination:=nextWs.Range("B" & lastRow + 1)
Application.CutCopyMode = False
End Sub
Private Function GetWorksheetIndex(ByVal ws As Worksheet) As Long
Dim w As Worksheet
For Each w In ws.Parent.Worksheets
Dim counter As Long
counter = counter + 1
If w.Name = ws.Name Then
GetWorksheetIndex = counter
Exit Function
End If
Next w
End Function
2nd EDIT:
I think you can rewrite HyperActive to something like this:
Sub HyperActive(ByVal rng As Range)
Dim ws As Worksheet
Set ws = rng.Parent
Dim fullAddress As String
fullAddress = "'" & ws.Name & "'!" & rng.Address
ws.Hyperlinks.Add Anchor:=rng, Address:="", SubAddress:=fullAddress, TextToDisplay:=rng.Text
End Sub
Then in the main Workbook_SheetFollowHyperlink code, add the following line:
HyperActive rng:=nextWs.Range("A" & lastRow + 1)
Column B is Employee name and is also an individual Worksheet name.
Anticipated Outcome: A hyperlink to the individual Worksheet on each item in column B.
Issue: The code starts and stops at the top of the list and puts in a hyperlink to the last employee on the list.
Sub HyperlinkAdd()
ts= "Employee List"
lx = sheets(ts).Range("L1").value
Sheets(ts).Range("L1").Formula= "=Subtotal(3,B4:B1000)+3"
For x = 3 to lx
If Range("B" & x).value <> "" And Range("B" & x).value <> "Employees" Then
Sheets(ts).Hyperlinks.Add Anchor:Selection, Address:="", _
Subaddress:="'" & Range("B" & x) & "'!A1"
Else
End if
Next X
End Sub
Try this:
Sub add_hyperlink()
Dim target_range As Range
Dim cell As Range
Set target_range = ThisWorkbook.Sheets("Sheet1").Range("B1", Range("B1").End(xlDown))
For Each cell In target_range
ThisWorkbook.Sheets("Sheet1").Hyperlinks.Add Anchor:=cell, Address:="https://www.google.com/", SubAddress:= _
"Sheet1!A1", TextToDisplay:=cell.Value
Next cell
End Sub
How about the following, simply amend the range you want to work with, I've set it up so it works from B1 to the last populated cell on Column B:
Sub HyperlinkAdd()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your working worksheet, amend as required
Dim LastRow As Long
Dim rng As Range, cell As Range
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'get the last row with data on Column b
Set rng = ws.Range(ws.Range("B1"), ws.Range("B" & LastRow))
'set the range to work with
For Each cell In rng
If cell.Value <> "" And cell.Value <> "Employees" Then
ws.Hyperlinks.Add Anchor:=cell, Address:="", SubAddress:=cell.Value & "!A1", TextToDisplay:=cell.Value
End If
Next
End Sub
I take a different tack and make a table of contents with each sheet (with exceptions) added to the list, and hyperlinks forward and back. You'll want to change the location of the "return" link on the employee sheet to somewhere suitable.
Private Sub Make_TOC()
'TOC Table of contents Hyperlink
Dim bkEmployees As Workbook
Set bkEmployees = ActiveWorkbook
Dim shContents As Worksheet, shDetail As Worksheet
If Not WorksheetExists("Contents") Then
Set shContents = bkEmployees.Sheets.Add(before:=ActiveWorkbook.Sheets(1))
shContents.Name = "Contents"
Else
Set shContents = bkEmployees.Sheets("Contents")
shContents.Move before:=bkEmployees.Sheets(1)
End If
shContents.Activate
shContents.Range("A1").Select
shContents.Columns("A:B").NumberFormat = "#"
For locX = 2 To bkEmployees.Sheets.Count
Select Case bkEmployees.Sheets(locX).Name
'add any sheets you don't want messed with
Case "Sheet1", "Sheet2", "Contents"
'don't include the sheets above in the TOC
Case Else
shContents.Cells(locX, 1) = bkEmployees.Sheets(locX).Name
shContents.Cells(locX, 1).Select
strSubAddress = "'" & shContents.Cells(locX, 1).Value & "'!A1"
shContents.Hyperlinks.Add Anchor:=shContents.Cells(locX, 1), _
Address:="", SubAddress:="'" & bkEmployees.Sheets(locX).Name & "'" & "!A1", _
TextToDisplay:=bkEmployees.Sheets(locX).Name, ScreenTip:="Go to Detail Sheet"
'change this code to put the anchor for the return link somewhere suitable.
bkEmployees.Sheets(locX).Hyperlinks.Add Anchor:=bkEmployees.Sheets(locX).Cells(1, 1), _
Address:="", SubAddress:="'" & shContents.Name & "'" & "!A" & locX, _
TextToDisplay:="Return to TOC", ScreenTip:="Return to Table of Contents"
End Select
Next locX
shContents.Range("A1").Value = "Table Of Contents"
shContents.Range("A1").Select
shContents.Columns("A").AutoFit
End Sub