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"),"")
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
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.
MY Question: Macro Needed
i have 2 excel files, the first is a master file that contains list of all the job#'s. the second file is a template that contains formulas.
First excel File looks like this:
ColumnA
Job# 1
Job# 2
Job# 3
Job# 4
the second file is a template that looks up the job and its details
What i want is a code that create an excel file for each job that is a copy of the template but i want to rename it as the Job# 1 , Job# 2 ...etc. in a specific folder.
The Tricky Part is that i do not want to overwrite the file if it already exists.
is this possible? if so any help would be appreciated.
Thank you
Try this code. It is a bit rough and untested, but should do the job. You need to have the Masterwork book in the same directory as the template.
Option Explicit
Sub CopyData()
Dim wksCurrent As Worksheet, wkbNew As Workbook
Dim rng As Range, c As Range, LastCell As Range
Dim wkbPath As String, wkbFileName As String, LFilename As String, wkbNewPath As String
Dim i As Integer
Dim lrow As Long, LastRowInput As Long
Application.ScreenUpdating = False
Set wksCurrent = ThisWorkbook.Sheets("Sheet1")
Set rng = Selection
On Error GoTo errHandler
wkbPath = ActiveWorkbook.Path & "\"
wkbNewPath = wkbPath & "JobTemplate.xlsx"
Set wkbNew = Workbooks.Open(wkbNewPath)
LastRowInput = wksCurrent.Cells(Rows.Count, "A").End(xlUp).Row
' If nothing is selected in column A
' GoTo Error Handling
If rng.Cells(1, 1) Is Nothing Then
GoTo errHandler
End If
For Each c In rng.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.Count - 1, 0).End(xlUp).Row
wksCurrent.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
Next
Application.ScreenUpdating = True
' Error Handling
exitHandler:
LFilename = wkbPath & wkbNew.Worksheets(1).Range("B" & lrow) & ".xlsx"
If Dir(LFilename) <> "" Then
ChDir (wkbNewPath) 'To open in folder
LFilename = Application.GetSaveAsFilename(InitialFileName:="", FileFilter:="Excel Files (*.xls), *.xls")
End If
If (LFilename <> "" And LFilename <> "False") Then
ActiveWorkbook.SaveAs LFilename
Else
'filename is still empty - user may have cancelled GetSaveAsFilename Dialog
'do something to handle this possibility...
MsgBox "file was not saved!"
End If
Exit Sub
errHandler:
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Exit Sub
End Sub
I am trying to develop a quick and easy project management tracker. I currently am using a inputbox to get the name of the project (PrjName) to add. The code will then copy the template and paste it into the "Projects" worksheet at the next available COLUMN (+1 for extra space between projects). I then want to add the PrjName as a list of projects on the dashboard worksheet but adding it as a hyperlink that will link to the appropriate column where the project has been pasted on the "Projects" worksheet. I have figured out how to copy/paste the way I want it to look, but I don't know how to even start creating a reference for the hyperlink. I thought I could possibly do this by using the project name to create a named range that somehow references the information pasted and then reference that name for the hyperlink but am not sure how to accomplish this. Here is what I have for so far but it is probably a long way from correct.
Private Sub CommandButton1_Click()
Dim FirstBlankCol As Range
PrjName = InputBox("Enter the name of the project", "User Input Required")
If PrjName = "" Then Exit Sub
'Find First Blank Cell to add new Project on Summary Worksheet
Set FirstBlankCol = Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Worksheets("Summary").Hyperlinks.Add Anchor:=FirstBlankCol, Address:="", SubAddress:= _
"PrjName", TextToDisplay:=PrjName
With Sheets("Projects")
Select Case Sheets("Projects").Range("A1") = ""
Case True 'paste in Col A if A1 is empty
Sheets("Template").Range("A1:F5").Copy
Sheets("Projects").Range("A1") _
.PasteSpecial Paste:=xlPasteColumnWidths
Sheets("Projects").Range("A1") _
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Case False 'paste in next col
Sheets("Template").Range("A1:F5").Copy
Sheets("Projects").Range("IV1").End(xlToLeft).Offset(0, 6) _
.PasteSpecial Paste:=xlPasteColumnWidths
Sheets("Projects").Range("IV1").End(xlToLeft).Offset(0, 6) _
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
End Select
Application.CutCopyMode = False
End With
End Sub
Give this a try:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim wsPrj As Worksheet
Dim wsTmp As Worksheet
Dim rngDest As Range
Dim strProjectName As String
strProjectName = InputBox("Enter the name of the project", "User Input Required")
If Len(Trim(strProjectName)) = 0 Then Exit Sub 'Pressed cancel
Set ws = ActiveSheet
Set wsPrj = Sheets("Projects")
Set wsTmp = Sheets("Template")
Application.ScreenUpdating = False
If Len(wsPrj.Range("A1").Text) = 0 Then Set rngDest = wsPrj.Range("A1") Else Set rngDest = wsPrj.Cells(1, Columns.Count).End(xlToLeft).Offset(, 6)
wsTmp.Range("A1:F5").Copy
rngDest.PasteSpecial xlPasteAllUsingSourceTheme
rngDest.PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Replace(strProjectName, " ", "_"), "='" & wsPrj.Name & "'!" & rngDest.Address
ws.Hyperlinks.Add ws.Cells(Rows.Count, "B").End(xlUp).Offset(1), "", Replace(strProjectName, " ", "_"), , strProjectName
Application.ScreenUpdating = True
End Sub
The code I am using takes sheets as array and copies them as XlValues, but there are few cells containing formulas which I want to keep and paste as xlFormats. How can i achieve that?
Sub CopyPasteSave()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
Dim Path As String, rcell As Range
Set rcell = Sheets("EPF Daily Report").Range("I5")
Path = "D:\"
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet1", "Sheet2"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("InletManifold", "Separator", "Crude Strippers & Reboilers ", "Water Strippers & Reboilers ", "Crude Storage&Export", "GSU,FLARE & GEN", "EPF Utility", "EPF Daily Report", "Choke Size")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
Application.DisplayAlerts = False
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Input box to name new file
'NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveAs Filename:=Path & " " & "EPF Daily Report" & " " & rcell.Value & ".xls"
ActiveWorkbook.Close SaveChanges:=True
.ScreenUpdating = False
End With
Exit Sub
ErrCatcher:
MsgBox "specified sheets do not exist within this work book"
End Sub
What I've done below, after the sheets are copied as values, is to copy cells that you specify from the original workbook, using PasteSpecial to keep their formulas intact. A couple of notes:
Added an array, CellsToCopy, that contains the addresses, e.g., B11 and B12 that
you want to copy with formulas. Mdoify this as needed.
Added wbSource and wbTarget workbook variables, to refer to in the PasteSpecial
Cleaned up your code, turning DisplayAlerts back on, and adding
to the error handling
Got rid of your Select statement and replaced with
Application.GoTo
Also, note that you don't have to do anything special to keep the formats, as the copy as values will not have changed them.
Sub CopyPasteSave()
Dim wbSource As Excel.Workbook
Dim wbTarget As Excel.Workbook
Dim nm As Name
Dim ws As Worksheet
Dim CellsToCopy() As String
Dim i As Long
Dim Path As String
Dim rcell As Range
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then
Exit Sub
End If
Set wbSource = ActiveWorkbook
Set rcell = Sheets("EPF Daily Report").Range("I5")
Path = "D:\"
'Enter cells to copy with formulas
CellsToCopy = Split(("B11,B12"), ",")
Application.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Sheet names go inside quotes, separated by commas
On Error GoTo ErrCatcher
wbSource.Sheets(Array("InletManifold", "Separator", "Crude Strippers & Reboilers ", "Water Strippers & Reboilers ", "Crude Storage&Export", "GSU,FLARE & GEN", "EPF Utility", "EPF Daily Report", "Choke Size")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hyperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
Set wbTarget = ActiveWorkbook
For Each ws In wbTarget.Worksheets
With ws
.Cells.Copy
.[A1].PasteSpecial Paste:=xlValues
For i = LBound(CellsToCopy) To UBound(CellsToCopy)
wbSource.Worksheets(ws.Name).Range(CellsToCopy(i)).Copy
ws.Range(CellsToCopy(i)).PasteSpecial xlPasteFormulas
Next i
Application.CutCopyMode = False
Application.DisplayAlerts = False
.Cells.Hyperlinks.Delete
Application.DisplayAlerts = True
Application.Goto .Range("A1")
End With
Next ws
With wbTarget
' Remove named ranges
For Each nm In .Names
nm.Delete
Next nm
' Input box to name new file
'NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
.SaveAs Filename:=Path & " " & "EPF Daily Report" & " " & rcell.Value & ".xls"
.Close SaveChanges:=True
End With
Exit_Point:
Application.ScreenUpdating = False
Application.DisplayAlerts = True
Exit Sub
ErrCatcher:
MsgBox "specified sheets do not exist within this work book"
Resume Exit_Point
End Sub