I need to be able to auto add a Hyperlink to a worksheet in the same workbook.
The code below created a new report and names it according to the active cell on the Main page.
I want to Hyperlink that cell to the newly created sheet with the same name.
Sub New_sheet()
Dim ShtName As String
Application.DisplayAlerts = False
On Error GoTo ErrMsg
ShtName = ActiveCell.Value2 ' <-- save the value of the ActiveCell
Set ws = Sheets("Blank incident tab")
ws.Copy After:=Sheets("Incident Catagories")
Set wsNew = Sheets(Sheets("Incident Catagories").Index + 1)
wsNew.Name = ShtName
Exit Sub
ErrMsg:
MsgBox ("That incident report already Exsists, Please chaeck and open a new incident"), , "Error Duplicate incident"
Sheets("Blank incident tab (2)").Delete
Application.DisplayAlerts = True
End Sub
Related
I have created my worksheet with a template sheet. I also create a button to copy the template sheet and put any new created sheets after the template sheet.
Everything is still OK if the 'Template' is visible. When I hide the 'Template', only the latest created sheet is visible, other are auto hidden.
Could you please have a look at my script and advise me how to fix that? I want any new created sheet will be visible and put after the hidden template sheet.
Here is my script
Sub NewSheet()
Dim newWS As Worksheet
Dim TemplateWS As Worksheet
Dim newWSName As String
Retry:
newWSName = InputBox("Enter Activity name.", "New Sheet Name")
If newWSName = "" Then Exit Sub
For Each ws In Worksheets
If ws.Name = newWSName Then
MsgBox newWSName & " exist already. Pick another name.", vbExclamation, "Sheet Name Exists"
GoTo Retry
End If
Next ws
Set TemplateWS = Sheet7
TemplateWS.Activate
TemplateWS.Copy After:=ActiveWorkbook.Sheets("template 1")
ActiveSheet.Name = newWSName
Range("A1").Select
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'Summary'!A1", TextToDisplay:="Click to Summary"
ActiveSheet.Tab.ColorIndex = 19
End Sub
Thank you so much as always.
Normally a copied sheet becomes the active sheet but this doesn't happen if the copied sheet is hidden. Solution is to make template visible, copy and then hide.
Option Explicit
Sub NewSheet()
Dim wsTemplate As Worksheet, ws As Worksheet
Dim newWSName As String
Retry:
newWSName = InputBox("Enter Activity name.", "New Sheet Name")
If newWSName = "" Then Exit Sub
For Each ws In ThisWorkbook.Sheets
If ws.Name = newWSName Then
MsgBox newWSName & " exist already. Pick another name.", vbExclamation, "Sheet Name Exists"
GoTo Retry
End If
Next ws
Set wsTemplate = Sheets("Template 1")
wsTemplate.Visible = True
wsTemplate.Copy After:=wsTemplate
With ActiveSheet
.Name = newWSName
.Range("A1").Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="'Summary'!A1", _
TextToDisplay:="Click to Summary"
.Tab.ColorIndex = 19
End With
wsTemplate.Visible = False
End Sub
I modified code from Copy worksheet into different workbook replacing current data.
If I deselect range or I have selected different cell than A1, code falls into 1004 error.
Sub TG_update()
Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet, ws3Format As Worksheet, ws4Format As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("[add your path.xlsx]")
Set ws1Format = wb1.Sheets("SheetA1")
Set ws2Format = wb2.Sheets("SheetB1")
Set ws3Format = wb1.Sheets("SheetA2")
Set ws4Format = wb2.Sheets("SheetB2")
'' Copy the cells of the "Format" worksheet.
ws2Format.Cells.Copy
'' Paste cells to the sheet "Format".
wb1.Sheets("SheetA1").Paste
ws4Format.Cells.Copy
wb1.Sheets("SheetB1").Paste
wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
wb1.Sheets("Store").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Date successfully updated"
End Sub
Please try this code. Instead of copying and pasting millions of blank cells this code copies the worksheet from the source and pastes it to the workbook with the code. If the action is successful the old sheet is deleted. The final report alerts about errors if sheets weren't found.
Sub TG_update()
' 016
Dim Wb As Workbook ' ThisWorkbook
Dim WbS As Workbook ' Source
Dim Ffn As String ' Full FileName
Dim Ws As Worksheet
Dim TabName() As String
Dim i As Integer ' TabName index
Dim n As Integer ' tab counter
Set Wb = ThisWorkbook
' specify the workbook to be copied from: Full path and name
Ffn = "F:\AWK PC\Drive E (Archive)\PVT Archive\Class 1\1-2018 (Jan 2020)\TXL 180719 Z Distance.xlsm"
' enumerate the sheet names in CSV format (sheets must exist in Wb)
TabName = Split("SheetA1,SheetB1", ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set WbS = Workbooks.Open(Ffn)
For i = 0 To UBound(TabName)
On Error Resume Next ' suppress error if worksheet isn't found
WbS.Worksheets(TabName(i)).Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
If Err.Number = 0 Then
n = n + 1
End If
Next i
WbS.Close SaveChanges:=False
On Error GoTo 0
For i = 0 To UBound(TabName)
For Each Ws In Wb.Worksheets
If InStr(Ws.Name, TabName(i) & " (") = 1 Then
Wb.Worksheets(TabName(i)).Delete
Ws.Name = TabName(i)
End If
Next Ws
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox n & " of " & i & " worksheets were successfully updated.", _
vbInformation, "Action report"
End Sub
Creative names like Wb1, Wb2, Ws1, Ws2, SheetA1, SheetA2 represent the punishment imaginative programmers inflict on those who come after them to correct their hastily concocted code. Give your VBA project a better reputation by bestowing names on your two worksheets that permit their identification.
I have the following code that produces a new worksheet. I'm trying to name the new worksheet using a Phrase, the content in Cell 1, and the date in Cell 2.
Cell 1 will contain some data that are inserted via Data Validation (4 options in total) and Cell 2 will have a date.
EXAMPLE:
Worksheet INPUTS Range C3. Cell 1 value = Trade Activities, Purchases, Sales...etc
Worksheet INPUTS Range C2. Cell 2 value = 2.11.2020
The new workbook's name will be "Client Name Trade Activities - 2.11.2020"
both Cell 1 and Cell 2 will be in the INPUTS worksheet
Private Sub CommandButton1_Click()
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim formatDate As String
Dim fileName As String
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
If sourceSheet.AutoFilterMode Then sourceSheet.AutoFilterMode = False
If ThisWorkbook.Worksheets("INPUTS").Range("C3").Value <> vbNullString Then
formatDate = Format(Sheets("INPUTS").Range("C3"), "YYYY.MM.DD")
End If
fileName = "Name - " & ActivityName & formatDate
sourceSheet.Outline.ShowLevels ColumnLevels:=1
sourceSheet.Range("A:M").AutoFilter Field:=12, Criteria1:="<>0"
Set targetWorkbook = Workbooks.Add
sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
targetWorkbook.Sheets("sheet1").Columns("A:AC").EntireColumn.AutoFit
targetWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName & ".xlsx", FileFormat:=51
End Sub
Some things to remember:
Define and reuse your variables whenever you can
Try to add comments to your code, explaining the purpose of what you're doing (your future self or whom ever is going to work with your files, is going to thank you)
Leave spaces between your code's main parts, so it's more readable
EDIT: Added error handler, for when user clicks "No" when asking to overwrite existing file
Code:
Private Sub CommandButton1_Click()
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim formatDate As String
Dim fileName As String
On Error GoTo CleanFail
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
' Remove filter
If sourceSheet.AutoFilterMode Then sourceSheet.AutoFilterMode = False
If sourceSheet.Range("F1").Value <> vbNullString Then
formatDate = Format(sourceSheet.Range("F1").Value, "YYYY.MM.DD")
End If
' Set the new workbook file name
fileName = "NAME - " & formatDate
' Filter the fileNames
sourceSheet.Range("A:C").AutoFilter Field:=2, Criteria1:="<>"
' Add new workbook and set reference
Set targetWorkbook = Workbooks.Add
' Copy the visible fileNames in a new workbook
sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
' Save the new workbook
targetWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName & ".csv", FileFormat:=xlCSV
CleanExit:
Exit Sub
CleanFail:
Select Case Err.Number
Case 1004
MsgBox "You cancel the process"
Resume Next
Case Else
' Do something else? handle it properly...
MsgBox "Something went wrong..."
Resume CleanExit
End Select
End Sub
Let me know if it works
I am working on a Userform that will copy a specific sheet from Workbook A and paste it into Workbook B (essentially archiving that data). The Userform presents the user with a combo-box dropdown to select the sheet name to be copied. I receive a subscript out of range error however when using the sheets.copy command. Here is my code with names modified for ease of reading:
Dim ws as Worksheet
Dim WorkbookA as Workbook
Dim WorkbookB as Workbook
Dim ComboBoxValue as String
Set WorkbookA as ActiveWorkbook
Set WorkbookB as Workbook.Open("C:File Path Here")
With ThisWorkbook
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name = UserForm1.ComboBox1.Text Then
ComboBoxValue = ws.Name
Worksheets(ComboBoxValue).Copy _
After:=Workbooks("Workbook B.xlsm").Sheets(Sheets.Count)
' Run-Time 9 Subscript Out of Range Error occurs on line above ^
ActiveSheet.Name = UserForm1.ComboBoxSelection.Text
WorkbookB.Save
WorkbookB.Close
WorkbookA.Activate
Application.CutCopyMode = False
End If
Next ws
End With
The root of your error is improper refenceing of the workbook. There are a lot of other issues, too.
Unnecassary reference to ThisWorkbook
Unnecassary loop through all worksheets
Unnecassary renaming of copied sheet
Unnecassry / incorrect references to the ActiveWorkbook and ActiveSheet
No Error Handling
Improper indenting
Your code, refactored. This is written as a button click event in the UserForm. Update to suit your needs.
Option Explicit
Const ArchiveFilePath As String = "C:\Path\To\ArchiveBook.xlsx"
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim WorkbookA As Workbook
Dim WorkbookB As Workbook
Dim wsName As String
Application.ScreenUpdating = False
Set WorkbookA = ActiveWorkbook
wsName = UserForm1.ComboBox1.Text
If wsName = vbNullString Then Exit Sub
On Error Resume Next 'Handle possibility that Open fails
Set WorkbookB = Workbooks.Open(ArchiveFilePath)
On Error GoTo 0
If WorkbookB Is Nothing Then
MsgBox "Failed to open " & ArchiveFilePath, vbOKOnly, "Error"
Exit Sub
End If
'Check if specified ws already exists in WorkbookB
Set ws = GetWorksheet(WorkbookB, wsName)
If Not ws Is Nothing Then
' Sheet already exists. What now?
MsgBox "Sheet " & wsName & " already exists in " & WorkbookB.Name & ". What now?", vbOKOnly, "Error"
WorkbookB.Close
Exit Sub
End If
Set ws = GetWorksheet(WorkbookA, wsName)
If ws Is Nothing Then
MsgBox "Sheet " & wsName & " does not exist in " & WorkbookA.Name, vbOKOnly, "Error"
WorkbookB.Close
Exit Sub
End If
ws.Copy After:=WorkbookB.Sheets(WorkbookB.Sheets.Count)
WorkbookB.Save
WorkbookB.Close
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
On Error GoTo EH
Set GetWorksheet = wb.Worksheets(wsName)
EH:
End Function
Change Sheets(Sheets.Count) to Sheets(Workbooks("Workbook B.xlsm").Sheets.Count)
In this context, Sheets(Sheets.Count) is referring to your source workbook object, so you must specify to count the sheets in the other book.
I would like to write a vba code that will not allow to add duplicate sheets with same name. I have a code that is assigned to button on the sheet that is used to change the name of the active sheet.
Sheets are copied from "Main" sheet and hence all the sheets will have button to rename the sheet based on the value selected in the cells A8 and K11 (Both these cells have drop down list with values).
My concern is when user selects the button to rename the sheet, it should look for all the sheets in workbook and display a message if duplicate sheet exists else it should rename the sheet. I am confused in passing values, I am still a starter. Please help
Sub RenameCurrentSheet()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
ThisWorkbook.Unprotect Password:="xyz"
For x = 1 To worksh
If ActiveSheet.Name = "MainSheet" Then
MsgBox "You Cannot Change Name of This Sheet!!!"
Exit For
Else
ActiveSheet.Name = Range("A8").Value & "-" & Range("K11").Value
Exit For
End If
Next x
Application.DisplayAlerts = True
ThisWorkbook.Protect Password:="xyz"
End Sub
To iterate through the worksheets use code like this:
dim wks as Worksheet
for I = 1 to Application.Worksheets.Count
set wks = Application.Worksheets(i)
Debug.Print wks.Name
.... whatever else you want do do
next i
set wks = Nothing ' When done with the object
Just try and reference the worksheet to see if it exists - if it throws an error, then the sheet doesn't exist.
Your code fails as you're always looking at the activesheet, but never changing which sheet is active.
Public Sub CopyAndRenameSheet()
Dim wrkSht As Worksheet
Dim sNewName As String
With ThisWorkbook
'Copy the template to the end of the workbook.
.Worksheets("MainSheet").Copy After:=.Sheets(.Sheets.Count)
'Set reference to last sheet in workbook (the one you've just copied).
Set wrkSht = .Worksheets(.Sheets.Count)
With wrkSht
'Get the new name from the ranges.
sNewName = .Range("A8") & "-" & .Range("K11")
If WorkSheetExists(sNewName) Then
MsgBox "You Cannot Change Name of This Sheet!!!", vbOKOnly + vbCritical
'Do something with the sheet, otherwise you'll be left with a
'sheet called something like "MainSheet (1)".
Application.DisplayAlerts = False
wrkSht.Delete
Application.DisplayAlerts = True
Else
.Unprotect Password:="xyz"
wrkSht.Name = sNewName
.Protect Password:="xyz"
End If
End With
End With
End Sub
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
This code copies the name to be assigned from the template instead of the ActiveSheet. If you create the name from the active sheet and make sure that the name meets Excel requirements for sheet names, this code ought to work.