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
Related
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
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 am new to VBA.
Thank you for your time. I have been Googling for 2 days and always get an error.
I have two sheets
Projects ( where I will store project names) and
Template (where new projects will be created using the "template" sheet)
I have 2 issues I am trying to solve :
How do I copy the format on an active sheet including conditional formatting and column width. PasteSpecial already copies all the colour design but not the column width/conditional formatting
When I run the code it creates a new sheet called Project Name,not sure where that is coming from.
This is the code I am using:
Sub Copy()
Sheets("Template").Range("A1:O100").Copy
ActiveSheet.PasteSpecial
End Sub
<<<<<<<<<<<<<<<<<<<<<<
I want to generate a project name, make sure it does not exist(no duplicate), open a new sheet and copy the template from "template".
The full codes is:
RunAll()
CreateProjectName
CreateNewTab
CopyPaste
End Sub
Dim AddData As Range
Dim AddName As String
Set AddData = Cells(Rows.Count, 4).End(xlUp).Offset(1, 0)
AddName = InputBox("Enter Project Name do not input manually", "Project Monitor")
If AddName = "" Then Exit Sub
AddData.Value = AddName
AddData.Offset(0, 1).Value = Now
End Sub
Function SheetCheck(sheet_name As String) As Boolean
Dim ws As Worksheet
SheetCheck = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = sheet_name Then
SheetCheck = True
End If
Next
End Function
Sub CreateNewTab()
Dim sheets_count As Integer
Dim sheet_name As String
Dim i As Integer
sheet_count = Range("D3:D1000").Rows.Count
For i = 1 To sheet_count
sheet_name = Sheets("Projects").Range("D3:D1000").Cells(i, 1).Value
If SheetCheck(sheet_name) = False And sheet_name <> "" Then
Worksheets.Add(After:=Sheets("Projects")).Name = sheet_name
End If
Next i
End Sub
Sub CopyPaste()
Sheets("Template").Range("A1:o100").Copy
ActiveSheet.PasteSpecial
End Sub
Option Explicit
Sub AddProject()
Dim ws As Worksheet, NewName As String
NewName = InputBox("Enter Project Name do not input manually", "Project Monitor")
' checks
If NewName = "" Then
MsgBox "No name entered", vbCritical
Exit Sub
Else
' check sheet not existing
For Each ws In ThisWorkbook.Sheets
If UCase(ws.Name) = UCase(NewName) Then
MsgBox "Existing Sheet '" & ws.Name & "'", vbCritical, "Sheet " & ws.Index
Exit Sub
End If
Next
End If
' check not existing in list
Dim wb As Workbook, n As Long, lastrow As Long, v
Set wb = ThisWorkbook
With wb.Sheets("Projects")
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
v = Application.Match(NewName, .Range("D1:D" & lastrow), 0)
' not existing add to list
If IsError(v) Then
.Cells(lastrow + 1, "D") = NewName
.Cells(lastrow + 1, "E") = Now
Else
MsgBox "Existing Name '" & NewName & "'", vbCritical, "Row " & v
Exit Sub
End If
End With
' create sheet
n = wb.Sheets.Count
wb.Sheets("Template").Copy after:=wb.Sheets(n)
wb.Sheets(n + 1).Name = NewName
MsgBox NewName & " added as Sheet " & n + 1, vbInformation
End Sub
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