I am trying to add a couple more worksheets after my master worksheet in a VBA code. I have a button to initiate the macro which I have the master module and the CreateSheet module tied to that button.
Sub CreateSheet()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Tempo"
End Sub
This is what I have in the CreateSheet module, the code runs but no sheets are created.
Public polerow As XlRowCol
Public MRBook, RDBook As Workbook
Sheets(1).Name = "Make-Ready"
Set MRBook = Worksheets("Make-Ready").Parent
This is what I have in the master module that produces all my output. I really would prefer to keep my macro to separate modules like this.
Try doing this, you can always use the same procedure without the need to change it's code:
Sub NewSheet(SheetName As String)
Dim SheetExists As Boolean
With ThisWorkbook
On Error Resume Next
SheetExists = (.Worksheets(SheetName).Name <> "")
On Error GoTo 0
If SheetExists = False Then
.Sheets.Add After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = SheetName
Else
Application.DisplayAlerts = False
.Sheets(SheetName).Delete
Application.DisplayAlerts = True
.Sheets.Add After:=.Sheets(.Sheets.Count)
.Sheets(wb.Sheets.Count).Name = SheetName
End If
End With
End Sub
'to call the newsheet you can do this
Sub Test()
NewSheet "Make-Ready"
End Sub
Related
I've got a workbook where I am creating a button that allows to save two specific sheets without formula's (the purpose being that the sheets are going to be send to partners and costumers). I would like the sheets to be saved in a single document somewhere on my computer, and still have the current "design" with colors, setup etc.
I've currently written this code, which does everything that I've described, except deleting the formulas...
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Hope you can help :-)
I have a sheet I use something similar for, I'll adjust the code a bit to work with your scenario. If you don't want the settings to change, delete the TurnOnFunctions & TurnOffFunctions subs.
This code will only break the links, not necessarily all the formulas. So if a formula references another spreadsheet it will be a static value; however, if it is a simple formula that stays within the spreadsheet it will stay that way.
Also add your workbook name to the respective area.
Sub NewWorkbooks()
'This will make seperate workbooks for each of the tabs listed
Dim wb As Workbook
Dim NewBook As Workbook
Dim ws As Worksheet
Call TurnOffFunctions
Set wb = ActiveWorkbook
For Each ws In Workbooks("YOUR WORKBOOK NAMR"). _
Worksheets(Array("frontpage", "mobile"))
ws.Copy
Set NewBook = ActiveWorkbook
With NewBook
Call break_links(NewBook)
.SaveAs Filename:="C:XXXX" & "NAME", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
Next
Call TurnOnFunctions
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
Private Sub TurnOffFunctions()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
Private Sub TurnOnFunctions()
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
You can use yours too with this mod (untested):
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
Call break_links ActiveWorkbook
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
I have an issue with below code.
I want to delete all visible sheets but a certain sheet, when a user closes the workbook.
This is the code:
Private Sub workbook_BeforeClose(cancel As Boolean)
Dim ws As Worksheet
For Each ws In Workbook
If ws.Visible = xlSheetVisible Then
If ws.Name <> "Choose BU" Then ws.Delete
End If
Next ws
End Sub
It says "Object required", however I thought the worksheet per default is an object in VBA?
You could try:
Option Explicit
Sub test()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
With ws
If .Visible = True And .Name <> "Choose BU" Then
.Delete
End If
End With
Next ws
Application.DisplayAlerts = True
End Sub
I wrote a code that is opening a window in which I can select a the excel workbook (#2) I want to copy and import the worksheet from.
The Code is then checking whether the wanted worksheet (named "Guidance") exists in the opened workbook (#2).If so it should be copied and pasted into the current workbook (#1).
After pasting the worksheet the workbook (#2) should be closed again.
So far the code does what I want it to do, as it opens the window and lets me select the wanted worksheet (named "Guidance") but I have the bug (not sure if the translation is correct)
"Runtime error '9': index out of range"
where the worksheet is supposed to be copied and pasted.
Any help on that would be very much appreciated! Thanks in advance.
Private Function SheetExists(sWSName As String, Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then
Set InWorkbook = ThisWorkbook
End If
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
On Error GoTo 0
End Function
Sub GuidanceImportieren()
Dim sImportFile As String, sFile As String
Dim sThisWB As Workbook
Dim vFilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisWB = ActiveWorkbook
sImportFile = Application.GetOpenFilename("Microsoft Excel Workbooks,
*xls; *xlsx; *xlsm")
If sImportFile = "False" Then
MsgBox ("No File Selected")
Exit Sub
Else
vFilename = Split(sImportFile, "|")
sFile = vFilename(UBound(vFilename))
Application.Workbooks.Open (sImportFile)
Set wbWB = Workbooks("sImportFile")
With wbWB
If SheetExists("Guidance") Then
Set wsSht = .Sheets("Guidance")
wsSht.Copy Before:=sThisWB.Sheets("Guidance")
Else
MsgBox ("No worksheet named Guidance")
End If
wbWB.Close SaveChanges:=False
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The issue is here
Set wbWB = Worksheets("Guidance") '<-- this should be a workbook not a worksheet?
With wbWB '<-- this with is useless until …
If SheetExists("Guidance") Then
Set wsSht = .Sheets("Guidance") '<-- … until Sheets here starts with a dot
wsSht.Copy Before:=sThisWB.Sheets("Guidance") 'if the error is here then there is no sheet "Guidance" in sThisWB
Else
MsgBox ("No worksheet named Guidance")
End If
wbWB.Close SaveChanges:=False
End With
Also note that SheetExists("Guidance") does not check in a specific workbook (which may fail). I recommend to extend the function to:
Private Function SheetExists(WorksheetName As String, Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then
Set InWorkbook = ThisWorkbook 'fallback if not set
End If
Dim ws As Worksheet
On Error Resume Next
Set ws = InWorkbook.Worksheets(WorksheetName)
SheetExists = Not ws Is Nothing
On Error Goto 0 'necessary because the Err.Number will not be cleared on End Function
End Function
So you can test if a worksheet exists in a specific workbook like
SheetExists("Guidance", sThisWB)
SheetExists("Guidance", wbWB)
Sub GuidanceImportieren()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sImportFile As String
sImportFile = Application.GetOpenFilename("Microsoft Excel Workbooks, *xls; *xlsx; *xlsm")
If sImportFile = False Then 'false should not be "false"
MsgBox "No File Selected"
Exit Sub
Else
Dim vFilename As Variant
vFilename = Split(sImportFile, "|")
Dim sFile As String
sFile = vFilename(UBound(vFilename))
Dim ImportWorkbook As Workbook
Set ImportWorkbook = Application.Workbooks.Open(sImportFile)
If SheetExists("Guidance", ImportWorkbook) Then
ImportWorkbook.Sheets("Guidance").Copy Before:=ThisWorkbook.Sheets("Guidance")
'you might need to change it into something like this:
Else
MsgBox "No worksheet named Guidance"
End If
ImportWorkbook.Close SaveChanges:=False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I am trying to add an Excel sheet named "Temp" at the end of all existing sheets, but this code is not working:
Private Sub CreateSheet()
Dim ws As Worksheet
ws.Name = "Tempo"
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
End Sub
Can you please let me know why?
Try this:
Private Sub CreateSheet()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Tempo"
End Sub
Or use a With clause to avoid repeatedly calling out your object
Private Sub CreateSheet()
Dim ws As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Tempo"
End With
End Sub
Above can be further simplified if you don't need to call out on the same worksheet in the rest of the code.
Sub CreateSheet()
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Temp"
End With
End Sub
Kindly use this one liner:
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "new_sheet_name"
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "XYZ"
(when you add a worksheet, anyway it'll be the active sheet)
Try this:
Public Enum iSide
iBefore
iAfter
End Enum
Private Function addSheet(ByRef inWB As Workbook, ByVal inBeforeOrAfter As iSide, ByRef inNamePrefix As String, ByVal inName As String) As Worksheet
On Error GoTo the_dark
Dim wsSheet As Worksheet
Dim bFoundWS As Boolean
bFoundWS = False
If inNamePrefix <> "" Then
Set wsSheet = findWS(inWB, inNamePrefix, bFoundWS)
End If
If inBeforeOrAfter = iAfter Then
If wsSheet Is Nothing Or bFoundWS = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = inName
Else
Worksheets.Add(After:=wsSheet).Name = inName
End If
Else
If wsSheet Is Nothing Or bFoundWS = False Then
Worksheets.Add(Before:=Worksheets(1)).Name = inName
Else
Worksheets.Add(Before:=wsSheet).Name = inName
End If
End If
Set addSheet = findWS(inWB, inName, bFoundWS) ' just to confirm it exists and gets it handle
the_light:
Exit Function
the_dark:
MsgBox "addSheet: " & inName & ": " & Err.Description, vbOKOnly, "unexpected error"
Err.Clear
GoTo the_light
End Function
Try to use:
Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = "MySheet"
If you want to check whether a sheet with the same name already exists, you can create a function:
Function funcCreateList(argCreateList)
For Each Worksheet In ThisWorkbook.Worksheets
If argCreateList = Worksheet.Name Then
Exit Function ' if found - exit function
End If
Next Worksheet
Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = argCreateList
End Function
When the function is created, you can call it from your main Sub, e.g.:
Sub main
funcCreateList "MySheet"
Exit Sub
Try switching the order of your code. You must create the worksheet first in order to name it.
Private Sub CreateSheet()
Dim ws As Worksheet
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = "Tempo"
End Sub
thanks,
This will give you the option to:
Overwrite or Preserve a tab that has the same name.
Place the sheet at End of all tabs or Next to the current tab.
Select your New sheet or the Active one.
Call CreateWorksheet("New", False, False, False)
Sub CreateWorksheet(sheetName, preserveOldSheet, isLastSheet, selectActiveSheet)
activeSheetNumber = Sheets(ActiveSheet.Name).Index
If (Evaluate("ISREF('" & sheetName & "'!A1)")) Then 'Does sheet exist?
If (preserveOldSheet) Then
MsgBox ("Can not create sheet " + sheetName + ". This sheet exist.")
Exit Sub
End If
Application.DisplayAlerts = False
Worksheets(sheetName).Delete
End If
If (isLastSheet) Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sheetName 'Place sheet at the end.
Else 'Place sheet after the active sheet.
Sheets.Add(After:=Sheets(activeSheetNumber)).Name = sheetName
End If
If (selectActiveSheet) Then
Sheets(activeSheetNumber).Activate
End If
End Sub
This is a quick and simple add of a named tab to the current worksheet:
Sheets.Add.Name = "Tempo"
I have an existing worksheet "StudentSheet1" which I need to add as many times as a user needs.
For eg, if a user enters 3 in cell "A1", saves it and closes the workbook.
I want to have three sheets: "StudentSheet1" , "StudentSheet2" and "StudentSheet3" when the workbook is opened next time.
So I will have the Code in "Workbook_Open" event. I know how to insert new sheets, but cant insert this particular sheet "StudentSheet1" three times
Here is my code:
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets.Add(Type:=xlWorksheet, After:=Worksheets(1))
Application.ScreenUpdating = True
End Sub
EDIT
Sorry I misread the question, try this:
Private Sub Workbook_Open()
Dim iLoop As Integer
Dim wbTemp As Workbook
If Not Sheet1.Range("A1").value > 0 Then Exit Sub
Application.ScreenUpdating = False
Set wbTemp = Workbooks.Open(Filename:="//Ndrive/Student/Student.xlsm")
wbTemp.Sheets("StudentSheet1").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
wbTemp.Close
Set wbTemp = Nothing
With Sheet1.Range("A1")
For iLoop = 2 To .Value
Sheets("StudentSheet1").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = "StudentSheet" & iLoop
Next iLoop
.Value = 0
End With
Application.ScreenUpdating = True
End Sub
Why are you wanting to add sheets on the workbook open? If the user disables macros then no sheets will be added. As Tony mentioned, why not add the sheets when called by the user?
EDIT
As per #Sidd's comments, if you need to check if the sheet exists first use this function:
Function SheetExists(sName As String) As Boolean
On Error Resume Next
SheetExists = (Sheets(sName).Name = sName)
End Function
user793468, I would recommend a different approach. :)
wbTemp.Sheets("StudentSheet1").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
is not reliable. Please see this link.
EDIT: The above code will fail if the workbook has defined names. Otherwise it is absolutely reliable. Thanks to Reafidy for catching that.
I just noticed OP's comment about the shared drive. Adding amended code to incorporate OP's request.
Tried and Tested
Option Explicit
Const FilePath As String = "//Ndrive/Student/Student.xlsm"
Private Sub Workbook_Open()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim TempName As String, NewName As String
Dim ShtNo As Long, i As Long
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Sheet1")
ShtNo = ws1.Range("A1")
If Not ShtNo > 0 Then Exit Sub
Set wb2 = Workbooks.Open(FilePath)
Set ws2 = wb2.Sheets("StudentSheet1")
For i = 1 To ShtNo
TempName = ActiveSheet.Name
NewName = "StudentSheet" & i
If Not SheetExists(NewName) Then
ws2.Copy After:=wb1.Sheets(Sheets.Count)
ActiveSheet.Name = NewName
End If
Next i
'~~> I leave this at your discretion.
ws1.Range("A1").ClearContents
LetsContinue:
Application.ScreenUpdating = True
On Error Resume Next
wb2.Close savechanges:=False
Set ws1 = Nothing
Set ws2 = Nothing
Set wb2 = Nothing
Set wb1 = Nothing
On Error GoTo 0
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
'~~> Function to check if sheet exists
Function SheetExists(wst As String) As Boolean
Dim oSheet As Worksheet
On Error Resume Next
Set oSheet = Sheets(wst)
On Error GoTo 0
If Not oSheet Is Nothing Then SheetExists = True
End Function