Macro to add new sheets to current workbook

kaskytrinh

New Member
Joined
Mar 29, 2013
Messages
21
I have the code, below, that creates Excel sheets titled and formatted the way I want into a new workbook. It creates X number of worksheets according to how many days in the month that is entered. However, I want to have the worksheets added to the CURRENT workbook--not open and create a new workbook. Specifically, I want the new sheets added immediately after the active worksheet. Help please?

I'm just returning back to
<acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-bottom-style: dotted; border-bottom-color: rgb(0, 0, 0); cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym> after a decade and I just don't remember how to do it. My knowledge is very limited.

Sub AddSheets()
Dim WS As Worksheet, WB As Workbook, TempWs As Worksheet, TempRange As Range
Dim MonthX As Date, Control As Variant, DaysInMonth As Byte, i As Byte, OldSheetCount As Byte
Dim RangeString As String

Set TempWs = ActiveSheet
RangeString = "A1:Z322"
Set TempRange = TempWs.Range(RangeString)
Control = InputBox("Enter month in the form of mm/yyyy.", "Month Entry", Month(Date) & "/" & Year(Date))
If IsDate(Control) Then
MonthX = CDate(Control)
DaysInMonth = Day(DateSerial(Year(MonthX), Month(MonthX) + 1, 0))
OldSheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = DaysInMonth
Set WB = Workbooks.Add
Application.SheetsInNewWorkbook = OldSheetCount
i = 1
For Each WS In WB.Sheets
WS.Name = MonthName(Month(MonthX)) & " " & i
TempWs.Activate
TempRange.Select
Selection.Copy
WS.Activate
WS.Range(RangeString).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
i = i + 1
Next
Else
MsgBox "Error while inputing start date. Please try again!"
End If
End Sub
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
You can try this on a copy of your file. I think I covered everything, but I did not test it. It should add the mumber of sheets based on the date entered into the input box, one at a time, naming and formatting each one as it goes.
Code:
Sub AddSheets()
Dim WS As Worksheet, WB As Workbook, TempWs As Worksheet, TempRange As Range
Dim MonthX As Date, Control As Variant, i As Long
Dim RangeString As String
Application.ScreenUpdating = False
Set TempWs = ActiveSheet
RangeString = "A1:Z322"
Set TempRange = TempWs.Range(RangeString)
Control = InputBox("Enter month in the form of mm/yyyy.", "Month Entry", Month(Date) & "/" & Year(Date))
    If IsDate(Control) Then
         MonthX = CDate(Control)
        DaysInMonth = Day(DateSerial(Year(MonthX), Month(MonthX) + 1, 0))
            For i = 1 To DaysInMonth
                Set WS = Sheets.Add After:=ThisWorkbook.ActiveSheet
                WS.Name = MonthName(Month(MonthX)) & " " & i
                TempWs.Activate
                TempRange.Select
                 Selection.Copy
                 WS.Activate
                 WS.Range(RangeString).Select
                 ActiveSheet.Paste
                 Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                 SkipBlanks:=False, Transpose:=False
                 Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                 SkipBlanks:=False, Transpose:=False
        Next
    Else
         MsgBox "Error while inputing start date. Please try again!"
    End If
Appliction.ScreenUpdating = True
End Sub
 
Last edited:

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
I inadvertantly deleted the declaration for DaysInMonth. It should be 'DaysInMonth As Long' added back to the Dim statements.(without the apostrophes)
 

Watch MrExcel Video

Forum statistics

Threads
1,130,444
Messages
5,642,180
Members
417,259
Latest member
gtacw

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top