I've assigned a macro to a cell so when it is clicked it makes a copy of a template sheet, asks what name you want for it, and then adds that name to the next blank cell in a column.
I've had a go at doing it below, it doesn't error, however it also doesn't hyperlink either.
How do i now also make the cell where the name goes hyperlink to that sheet?
Full vba on main sheet:
Public Sub CopySheetAndRenameByCell()
Dim newName As String
Dim Emrange As Range
Set Emrange = Application.Range("C" & Rows.Count).End(xlUp).Offset(1)
On Error Resume Next
newName = InputBox("Enter the name of the new project", "Copy worksheet", ActiveCell.Value)
If newName <> "" Then
Sheets("Project Sheet BLANK").Copy After:=Worksheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = newName
Emrange.Value = newName
Worksheets(newName).Select
Emrange.Select
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="newName!A1", TextToDisplay:="New sheet"
End If
End Sub
Like this:
Public Sub CopySheetAndRenameByCell()
Dim newName As String, Emrange As Range, wsNew As Worksheet, wb As Workbook
Dim wsIndex As Worksheet
newName = InputBox("Enter the name of the new project", _
"Copy worksheet", ActiveCell.Value)
If newName <> "" Then
Set wb = ThisWorkbook
wb.Worksheets("Project Sheet BLANK").Copy _
After:=wb.Worksheets(wb.Worksheets.Count)
Set wsNew = wb.Worksheets(wb.Worksheets.Count)
On Error Resume Next 'ignore error on rename
wsNew.Name = newName
On Error GoTo 0 'stop ignoring errors
Set wsIndex = wb.Worksheets("Index") 'for example
Set Emrange = wsIndex.Range("C" & Rows.Count).End(xlUp).Offset(1)
wsIndex.Hyperlinks.Add Anchor:=Emrange, _
Address:="", SubAddress:="'" & wsNew.Name & "'!A1", _
TextToDisplay:=wsNew.Name
'reset font style
Emrange.Font.Underline = xlUnderlineStyleNone
Emrange.Font.ColorIndex = xlAutomatic
If wsNew.Name <> newName Then 'in case sheet could not be renamed....
MsgBox "Name provided '" & newName & _
"' is not valid as a worksheet name!", vbExclamation
End If
End If
End Sub
Related
My below code does a few things, asks for a name of a new sheet, creates it and enters the name into the next blank C cell.
Cells next to this, D,E,F, and G have relevent data that i call from the new sheets when they are created EG: Project manager, start date etc.
Rather than having these all populated and having an ugly table with "#Ref!" everywhere I thought it would be best to do this whilst a new project is being created.
Basically, depending on the "EMRange" used below, for example the next one empty one being C6, I'd then like D6,E6,F6 and G6 to auto fill the formula from the cells above.
I gather I need to use selection.autofill but I'm unsure on how to get the destination to be those specific cells depending on what the EMRange was in the part of the script previous.
Public Sub CopySheetAndRenameByCell()
Dim newName As String, Emrange As Range, wsNew As Worksheet, wb As Workbook
Dim wsIndex As Worksheet
newName = InputBox("Enter the name of the new project", _
"Copy worksheet", ActiveCell.Value)
If newName <> "" Then
Set wb = ThisWorkbook
wb.Worksheets("Project Sheet BLANK").Copy _
After:=wb.Worksheets(wb.Worksheets.Count)
Set wsNew = wb.Worksheets(wb.Worksheets.Count)
On Error Resume Next 'ignore error on rename
wsNew.Name = newName
On Error GoTo 0 'stop ignoring errors
Set wsIndex = wb.Worksheets("Client Projects Overview")
Set Emrange = wsIndex.Range("C" & Rows.Count).End(xlUp).Offset(1)
wsIndex.Hyperlinks.Add Anchor:=Emrange, _
Address:="", SubAddress:="'" & wsNew.Name & "'!A1", _
TextToDisplay:=wsNew.Name
'reset font style
Emrange.Font.Underline = xlUnderlineStyleNone
Emrange.Font.ColorIndex = xlAutomatic
Emrange.Font.Name = "Century Gothic"
Emrange.Font.Size = "10"
If wsNew.Name <> newName Then 'in case sheet could not be renamed....
MsgBox "Name provided '" & newName & _
"' is not valid as a worksheet name!", vbExclamation
End If
End If
End Sub
Just added an if statement to my formula and auto-filled to all cells rather than trying to do it on a case by case basis in vba.
Ended up looking like this:
=IF(C5<>"",INDIRECT("'"&C5&"'"&"!"&"D3"),"")
Template sheet labeled = "COQ 001"
Log labeled = "Change Order Log"
I have gotten this far: Code below creates a new sheet based off of the template labeled "COQ 001", renames the new worksheet based on user input, goes back to the change order log and sets it to active, inserts a row after the last entry. I think I got that right.
Sub CreateSheet()
Dim xName As String
Dim xSht As Object
On Error Resume Next
xName = InputBox("Please enter new COQ #. For Example: COQ 001", "NEW CHANGE ORDER QUOTE")
If xName = "" Then Exit Sub
Set xSht = Sheets(xName)
If Not xSht Is Nothing Then
MsgBox "Sheet cannot be created as there is already a worksheet with the same name in this
workbook"
Exit Sub
End If
Sheets("COQ 001").Copy after:=Sheets(Sheets.Count)
Set xNWS = Sheets(Sheets.Count)
xNWS.Name = xName
'Link2Log Macro
Worksheets("Change Order Log").Activate
'Locates Last Cell
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
'Inserts Row Below
Range("10:10").EntireRow.Insert
End Sub
To keep going I need it to link specific cells of each newly created worksheet to the change order log sheet since that is my master log. Instead of COQ 001 which shows up on the formula, I would like it to be each newly created sheet.
If anyone can help finish the thought that would be great!!Thanks,
New Formula:
Thanks Nick, this is what the formula looks like:
Sub CreateSheet()
Dim xName As String
Dim xSht As Object
On Error Resume Next
xName = InputBox("Please enter new COQ #. For Example: COQ 001", "NEW
CHANGE ORDER QUOTE")
If xName = "" Then Exit Sub
Set xSht = Sheets(xName)
If Not xSht Is Nothing Then
MsgBox "Sheet cannot be created as there is already a worksheet with
the same name in this workbook"
Exit Sub
End If
Sheets("COQ 001").Copy after:=Sheets(Sheets.Count)
Set xNWS = Sheets(Sheets.Count)
xNWS.Name = xName
'Link2Log Macro
Worksheets("Change Order Log").Activate
Range("10:10").EntireRow.Insert
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "='xName'!R[-3]C[5]"
Range("C10").Select
ActiveCell.FormulaR1C1 = "='xName'!R[2]C:R[2]C[5]"
Range("D10").Select
ActiveCell.FormulaR1C1 = "='xName'!R[-2]C[3]"
Range("E10").Select
ActiveCell.FormulaR1C1 = "='xName'!R[-1]C[2]"
Range("G10").Select
ActiveCell.FormulaR1C1 = "='xName'!R[40]C"
Range("G11").Select
End Sub
But I get an error on the log:
LOG
You can try this:
Sub CreateSheet()
Dim xName As String, wb As Workbook
Dim ws As Worksheet
xName = InputBox("Please enter new COQ #. For Example: COQ 001", _
"NEWCHANGE ORDER QUOTE")
If xName = "" Then Exit Sub
Set wb = ThisWorkbook
If SheetExists(xName, wb) Then
MsgBox "Sheet '" & xName & "' cannot be created as there is already " & _
"a worksheet with the same name in this workbook"
Exit Sub
End If
wb.Worksheets("COQ 001").Copy after:=Sheets(Sheets.Count)
Set ws = wb.Sheets(Sheets.Count)
ws.Name = xName
With wb.Worksheets("Change Order Log")
.Activate
.Cells(Rows.Count, "B").End(xlUp).Offset(1).EntireRow.Insert 'add a row to the table
With .Cells(Rows.Count, "B").End(xlUp).Offset(1).EntireRow
.Columns("B").Formula = "='" & xName & "'!G7"
.Columns("C").Formula = "='" & xName & "'!C12" 'only need first cell of merged area
.Columns("D").Formula = "='" & xName & "'!G8"
.Columns("E").Formula = "='" & xName & "'!G9"
.Columns("G").Formula = "='" & xName & "'!G50" 'likewise
End With
End With
End Sub
Function SheetExists(SheetName As String, Optional wb As Excel.Workbook)
Dim s As Excel.Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set s = wb.Sheets(SheetName)
On Error GoTo 0
SheetExists = Not s Is Nothing
End Function
Note you don't need to select/activate ranges to work with them - just reference them directly.
I have a workbook with two sheet I copy to the end of the workbook.
I am trying to name the two sheet the same name via a InputBox and give them two different suffix as standard, the first is "xxx - Project" and the next is "xxx - Report".
I have placed the two sheets in an array. How do I reference the two sheet via the InputBox?
Public Sub CopySheets()
Dim shName As String 'Sheet name var
Dim shExists As Boolean
Do
shName = InputBox("Please enter name of new project", "New Project")
If shName <> "" Then
shExists = SheetExists(shName) 'Check for existing sheet name
If Not shExists Then
Worksheets(Array(1, 2)).Copy After:=Sheets(Sheets.Count)
Else
MsgBox "Project Name:" & Space(1) & shName & " already exists", vbOKOnly + vbCritical, "Deter"
End If
End If
Loop Until Not shExists Or shName = ""
End Sub
Private Function SheetExists(ByVal sheetName As String, _
Optional ByVal wb As Workbook)
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = Not wb.Worksheets(sheetName) Is Nothing
End Function
Sample image:
Something like that in in the if conditon
If Not shExists Then
Worksheets(Array(1, 2)).Copy After:=Sheets(Sheets.Count)
Dim ws As Worksheet
Set ws = Sheets(Sheets.Count - 1)
ws.Name = shName & "- project"
Set ws = Sheets(Sheets.Count)
ws.Name = shName & "- report"
Else
I have developed a code to copy a sheet and rename the sheet name with the value given in the insert box and then copy the same value in the summary sheet and select the last cell and paste the value but I want to create the hyperlink so that if i click on that value it will take me to that sheet.
I am stuck at the giving the proper subaddress.
Private Sub CommandButton1_Click()
Dim sName As String
Dim oRng As Range
sName = InputBox("New Shipment", "New AWB Number", "Enter the AWB Number")
If sName <> "" Then
ThisWorkbook.Sheets("Templete").Copy Before:=Sheets(3)
ActiveSheet.Name = sName
MsgBox "New AWB Number Tracking Added"
Else
MsgBox "Failed"
End If
Sheets("Summary").Select
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Activate
ActiveCell.Value = sName
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"'Sheet(3)'!A1"
End Sub
When I run this I am getting an error:
"Reference isn't valid"
Please help.
You can always run into issues when using Select and Activate but I suspect your main issue was your hyperlink sub address. You where trying to set it to 'Sheet(3)'!A1" which excel won't recognise as it is the sheet position (which VBA recognises) rather than the sheet name. Have a look at the below
Private Sub CommandButton1_Click()
Dim sName As String
Dim oRng As Range
Dim nWs As Worksheet
sName = InputBox("New Shipment", "New AWB Number", "Enter the AWB Number")
If sName <> "" Then
With ThisWorkbook
.Sheets("Templete").Copy Before:=.Sheets(3)
Set nWs = .Sheets(3)
End With
nWs.Name = sName
With Sheets("Summary")
With .Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
.Value2 = sName
.Parent.Hyperlinks.Add Anchor:=.Cells, Address:="", SubAddress:= _
"'" & nWs.Name & "'!A1"
End With
End With
MsgBox "New AWB Number Tracking Added"
Else
MsgBox "Failed"
End If
End Sub
You should probably also add to this a check to test against existing sheets for duplicate or invalid names entered by the user.
I want to copy multiple sheets to new workbook starting from range (A3) to end of the table of each table, so the following code was used but it copy the entire sheet.
Private Sub Copytonewworkbook_Click()
Dim NewName As String
Dim nm As name
Dim ws As Worksheet
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted" , vbYesNo, "NewCopy") = vbNo Then
Exit Sub
With Application
.ScreenUpdating = False
On Error GoTo ErrCatcher
Sheets(Array("Payroll", " Bank Letter")).Copy
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
ws.Cells(3,33)Paste:=xlCellTypeFormulas
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
This is a possible way to do it (a little advanced, as it does not use the copy, but it gets the values):
Public Sub CopyMe()
Dim lLastRow As Long
Dim rngToCopy As Range
Dim shtTarget As Worksheet
With ActiveSheet
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).row
Set rngToCopy = .Rows("3:" & lLastRow)
End With
Set shtTarget = ActiveWorkbook.Worksheets("Report")
shtTarget.Rows("1:" & rngToCopy.Rows.Count).value = rngToCopy.value
End Sub
You copy the rows from the third to the last value in the first column of the activesheet to a sheet named Report.
Addition:
On the fly, without trying you can do it like this:
Sheets(Array("Payroll", " Bank Letter")).Copy
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
ws.Paste:=xlCellTypeFormulas
WS.ROWS("1:3").Clear