Create new worksheets base on checkmarks in column

trmason · Jun 26, 2018

What i am working on is an estimating application for construction, i know there are many already out there but none that my boss likes.
First Part

I have a list of items on Sheet2 (Div’s) column C with a description in Column D. What I want to accomplish is for the user to check off the items wanted in Column B, then make new worksheets by coping worksheet Sheet7 (Blank Div Sh). Then rename the new sheet based on the description in column D Sheet2 (Div’s)
Here is the code I have been working on.
Sub AddSheets()

Application.ScreenUpdating = False
Columns().AutoFilter 1, "ChrW"
With Range("a23", Range("i" & Rows.Count).End(2))

Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("D23:D300")
With wBk

Sheets("Blank Div Sh").Select
Sheets("Blank Div Sh").Copy Before:=Sheets("Blank Div Sh") '.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub

The second part
Is to add a new row on Sheet4 (Spreadsheet) for each new Sheet with the Sheet name.

mumps · Jun 26, 2018

Try this approach:
Copy and paste this macro into the worksheet code module. Do the following: right click the tab for your "Div’s" sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Simply enter an "x" in column B in the row that contains the sheet you want to create and exit the cell.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Sheets("Blank Div Sh").Copy Before:=Sheets("Blank Div Sh")
    ActiveSheet.Name = Target.Offset(0, 2).Value
    Sheets("Spreadsheet").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = ActiveSheet.Name
    Application.ScreenUpdating = True
End Sub

trmason · Jun 26, 2018

the code work great to creat a new work sheet but when i go to clear the x the code want to make a new sheet with the name of "Blank Div Sh-02"

mumps · Jun 26, 2018

Try this version:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    If Target <> "" Then
        Sheets("Blank Div Sh").Copy Before:=Sheets("Blank Div Sh")
        ActiveSheet.Name = Target.Offset(0, 2).Value
        Sheets("Spreadsheet").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = ActiveSheet.Name
    End If
    Application.ScreenUpdating = True
End Sub

trmason · Jun 26, 2018

It works good the only thing is I need the Sheet name to go to "Spreadsheet column C and start on Row 18. I changed the offset from 1 to 3 and the ) to 18 but it did not work.

mumps · Jun 26, 2018

Try:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim LastRow As Long
    If Target <> "" Then
        Sheets("Blank Div Sh").Copy Before:=Sheets("Blank Div Sh")
        ActiveSheet.Name = Target.Offset(0, 2).Value
        LastRow = Sheets("Spreadsheet").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If LastRow < 18 Then LastRow = 17
        Sheets("Spreadsheet").Range("C" & LastRow + 1) = ActiveSheet.Name
    End If
    Application.ScreenUpdating = True
End Sub

trmason · Jun 26, 2018

We are get there the only thing is the sent to Spreadsheet is putting on the very bottom and i failed to mention that i have a row with sub totals and the code pastes the tab name below it.
thank you for your help.

is there a way to attach the file

mumps · Jun 26, 2018

You can't attach a file in this forum. Perhaps you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

trmason · Jun 26, 2018

here is a link to the file.
https://drive.google.com/file/d/1VadDyUPlMedjdmYGIP8TSXKmc8Yf4eje/view?usp=sharing

mumps · Jun 26, 2018

Try:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim LastRow As Long, firstBlank As Long
    If Target <> "" Then
        Sheets("Blank Div Sh").Copy Before:=Sheets("Blank Div Sh")
        ActiveSheet.Name = Left(Target.Offset(0, 2).Value, 31)
        LastRow = Sheets("Spreadsheet").Range("C:C").Find("General Requirements", LookIn:=xlValues, lookat:=xlWhole).Row
        firstBlank = Sheets("Spreadsheet").Range("C15:C21").Find("", SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
        Sheets("Spreadsheet").Range("C" & firstBlank) = Target.Offset(0, 2).Value
    End If
    Application.ScreenUpdating = True
End Sub

Create new worksheets base on checkmarks in column

trmason

New Member

Excel Facts

mumps

Well-known Member

trmason

New Member

mumps

Well-known Member

trmason

New Member

mumps

Well-known Member

trmason

New Member

mumps

Well-known Member

trmason

New Member

mumps

Well-known Member

Similar threads

Forum statistics

Share this page

Create new worksheets base on checkmarks in column

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock