Add Column & sheet with Button

[no1_fred]

Hello,
Can someone point me in the right direction?

Im looking to have a button that will do a few things.
-insert a new column (with the same formula as adjacent ones)
-fill in the value of cell on row 5 with the initials in cell "C20"

-create a new sheet (COPY OF EXISTING USER SHEET or a blank template from user sheet)
-rename the sheet with the initials in cell "C20"
-copy value of C21 into new sheet cell B1

- clear contents of MASTER cell C20 and C21


is all that even possible?
TIA.

[JOHN H. DAVIS]

Maybe:

Sub no1_fred()
Dim ws As Worksheet, x As Long
Set ws = ActiveSheet
x = ws.UsedRange.Columns.Count + 1
Columns(ActiveSheet.UsedRange.Columns.Count).Copy Cells(1, x)
Cells(5, ActiveSheet.UsedRange.Columns.Count) = Range("$C$20")
ws.Copy Before:=ActiveWorkbook.Sheets(1)
With ActiveSheet
    .Name = ws.Range("C20").Value
    .Cells(1, "B").Value = ws.Range("C21").Value
End With
ws.Range("C20:C21").ClearContents
End Sub

[no1_fred]

ohhh thanks John, very very close.

it seems the new column add does not go on and on. it just seems to cycle adding one then another then copies over the first.

That code copies the current sheet, (I need it to copy one of the other sheets(maybe I could name the sheet to be copied as "USER"))
what line would I edit to choose a different sheet to copy?

any way to make the new sheet add at the end of the tabs?

thanks very much for your very clever assistance.

[no1_fred]

is it easier to always add a new column after column "I" copying the formula from column "I" as id does it? ?

once again I appreciate your help.

[no1_fred]

Sub NewUser()
Dim ws As Worksheet, x As Long
Set ws = ActiveWorkbook.Sheets("MASTER")
x = ws.UsedRange.Columns.Count + 1
Columns(ActiveWorkbook.Sheets("MASTER").UsedRange.Columns.Count).Copy Cells(1, x)
Cells(6, ActiveWorkbook.Sheets("MASTER").UsedRange.Columns.Count) = Range("$C$20")
ActiveWorkbook.Sheets("BNC").Copy Before:=ActiveWorkbook.Sheets("PROJECTS")
With ActiveSheet
    .Name = ws.Range("C20").Value
    .Cells(1, "B").Value = ws.Range("C21").Value
End With
ws.Range("C20:C21").ClearContents
End Sub

ive made some changes that seem to sort the copy sheet issues, BUT im still having problems with the copy/new column. it overwrites existing ones.

[jaslake]

Hi no1_fred

Try this Code in the attached.

Sub NewUser()
   Dim ws           As Worksheet
   Dim x            As Long
   Dim c            As Long
   Dim d            As Long

   Set ws = ActiveWorkbook.Sheets("MASTER")
   With ws
      d = .Columns("B:B").Find("INITIALS", , xlValues, xlPart, xlByRows, xlNext, False).Row
      If .Cells(d, "C").Value = "" Then
         MsgBox "Enter the New User Information"
         Exit Sub
      End If
      Application.ScreenUpdating = False
      x = .UsedRange.Columns.Count
      .Range(.Cells(1, "G"), .Cells(1, x)).UnMerge
      .Range(.Cells(6, 1), .Cells(6, x)).UnMerge
      c = .Columns("A:B").Find("WEEK TOTALS:", , xlValues, xlPart, xlByRows, xlNext, False).Row - 1
      .Range(.Cells(c, 1), .Cells(c, x)).UnMerge
      .Columns(x - 1).Copy
      .Columns(x - 1).Insert Shift:=xlToRight
      Application.CutCopyMode = False
      .Cells(5, x) = Range("$C$" & d)
   End With
   
   ActiveWorkbook.Sheets("Template").Copy Before:=ActiveWorkbook.Sheets("PROJECTS")
   With ActiveSheet
      .Name = ws.Range("C" & d).Value
      .Cells(1, "B").Value = ws.Range("C" & d).Value
   End With

   With ws
      .Range("C" & c & ":C" & d + 1).ClearContents
      .Range(.Cells(1, "G"), .Cells(1, x + 1)).Merge
      .Range(.Cells(6, 1), .Cells(6, x + 1)).Merge
      .Range(.Cells(c, 1), .Cells(c, x + 1)).Merge
      .Activate
   End With
   Application.ScreenUpdating = True
End Sub

[no1_fred]

WOW.

That is nearly perfect.
unfortunately it is too complex for me to immediately understand how to make a very tiny tweak.
Can I have the users full name populated into the new sheets cell B2? (instead of just the initials?
Point me to what line would do that?
Would I need to add another variable like "d" and "find" the "name"??

Thank you so very much.

[jaslake]

Hi no1_fred

Try these mods...

With ActiveSheet
      .Name = ws.Range("C" & d).Value
      .Cells(1, "B").Value = ws.Range("C" & d + 1).Value '<---Change this line of Code
'      .Cells(1, "B").Value = ws.Range("C" & d).Value    '<---This line of Code should not be there
   End With

[no1_fred]

well that did it!

now to go try understand what all of your code does.
thank you again!!!

[jaslake]

I'll comment the Code and repost...it's really quite simple.

[jaslake]

Here's the Commented Code...any questions, please ask...

Sub NewUser()
   Dim ws           As Worksheet
   Dim x            As Long
   Dim c            As Long
   Dim d            As Long

   Set ws = ActiveWorkbook.Sheets("MASTER")
   With ws
   
      'if you were to add additional Projects, INITIALS will not ALWAYS be in C20.
      'So, find what Row it's in...
      d = .Columns("B:B").Find("INITIALS", , xlValues, xlPart, xlByRows, xlNext, False).Row
      
      'If the initials are blank...ask the User to complete the Form.
      If .Cells(d, "C").Value = "" Then
         MsgBox "Enter the New User Information"
         Exit Sub
      End If
      
      Application.ScreenUpdating = False
      'Find the last Column in the Worksheet
      x = .UsedRange.Columns.Count
      
      'Unmerge the following ranges...merged Cells mess with VBA
      .Range(.Cells(1, "G"), .Cells(1, x)).UnMerge
      .Range(.Cells(6, 1), .Cells(6, x)).UnMerge
      
      'we want to unmerge the Cells in the Row above "WEEK TOTALS" but
      'we may have added new Projects so we gotta find the Row Number
      c = .Columns("A:B").Find("WEEK TOTALS:", , xlValues, xlPart, xlByRows, xlNext, False).Row - 1
      
      'Now, unmerge the Row above "WEEK TOTALS"
      .Range(.Cells(c, 1), .Cells(c, x)).UnMerge
      
      'This works now because we've unmerged the Cells
      .Columns(x - 1).Copy
      .Columns(x - 1).Insert Shift:=xlToRight
      Application.CutCopyMode = False
      
      'Fill in the Initials fiels in Row 5
      .Cells(5, x) = Range("$C$" & d)
   End With
   
   'Create a new Worksheet for the INITIALS
   ActiveWorkbook.Sheets("Template").Copy Before:=ActiveWorkbook.Sheets("PROJECTS")
   With ActiveSheet
      'Nmae the Sheet
      .Name = ws.Range("C" & d).Value
      
      'Populate the Name Field
      .Cells(1, "B").Value = ws.Range("C" & d + 1).Value
   End With

   With ws
      'Clean up the Master Sheet and Remerge the appropriate Cells.
      .Range("C" & c & ":C" & d + 1).ClearContents
      .Range(.Cells(1, "G"), .Cells(1, x + 1)).Merge
      .Range(.Cells(6, 1), .Cells(6, x + 1)).Merge
      .Range(.Cells(c, 1), .Cells(c, x + 1)).Merge
      .Activate
   End With
   Application.ScreenUpdating = True
End Sub

[no1_fred]

that will go A VERY LONG WAY to help my understanding. thanks again!!

[no1_fred]

John, could you help me a little further.

Ive updated the sheet quite a bit with more functionality (with lots of help)
see attached.

It all works as I want in the attached condition. BUT I want to now hide the "projects" and "template" sheets.
when I do that and try to add a new user it just overwrites the last tab instead of making a new one.

any ideas?

thanks

[jaslake]

Add the 4 indicated lines of Code...

 Sheets("Template").Visible = True  '<---Add this line of Code
   Application.DisplayAlerts = False  '<---Add this line of Code
   ActiveWorkbook.Sheets("Template").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
   With ActiveSheet
      .Name = ws.Range("C" & d).Value
      .Cells(1, "B").Value = ws.Range("C" & d + 1).Value
      .Cells(2, "B").Value = ws.Range("C" & d + 2).Value
   End With
   Sheets("Template").Visible = False  '<---Add this line of Code
   Application.DisplayAlerts = True    '<---Add this line of Code

[no1_fred]

John,

My poor understanding ( I think maybe on the merge and un merge ) means ive messed something up.
I added a new Column A and Row 1 just to provide some white space.
But now new column add button does not add it at the end.

I tweaked the code but I think its the merged cells are stuffing it up.

Sub NewUser()
   Dim ws           As Worksheet
   Dim x            As Long
   Dim c            As Long
   Dim d            As Long

   Set ws = ActiveWorkbook.Sheets("MASTER")
    ActiveSheet.Unprotect "PFP1972!" 'Type your password here
   With ws
      d = .Columns("C:C").Find("INITIALS", , xlValues, xlPart, xlByRows, xlNext, False).Row
      If .Cells(d, "D").Value = "" Then
         MsgBox "Enter the New User Information"
         Exit Sub
      End If
     
      Application.ScreenUpdating = False
      x = .UsedRange.Columns.Count
      .Range(.Cells(2, "H"), .Cells(2, x)).UnMerge
      .Range(.Cells(7, 2), .Cells(7, x)).UnMerge
      c = .Columns("B:C").Find("WEEK TOTALS:", , xlValues, xlPart, xlByRows, xlNext, False).Row - 1
      .Range(.Cells(c, 2), .Cells(c, x)).UnMerge
      .Columns(x - 1).Copy
      .Columns(x - 1).Insert Shift:=xlToRight
      Application.CutCopyMode = False
      .Cells(6, x) = Range("$D$" & d)
   End With

    Sheets("Template").Visible = True
    Application.DisplayAlerts = False
   ActiveWorkbook.Sheets("Template").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
   With ActiveSheet
      .Name = ws.Range("D" & d).Value
      .Cells(1, "B").Value = ws.Range("D" & d + 1).Value
        .Cells(2, "B").Value = ws.Range("D" & d + 2).Value
   End With
Sheets("Template").Visible = False
 Application.DisplayAlerts = True
   With ws
      .Range("D" & c & ":D" & d + 2).ClearContents
      .Range(.Cells(2, "H"), .Cells(2, x + 1)).Merge
      .Range(.Cells(7, 2), .Cells(7, x + 1)).Merge
      .Range(.Cells(c, 7), .Cells(c, x + 1)).Merge
      .Activate
   End With
   Application.ScreenUpdating = True
      ActiveSheet.Protect "PFP1972!" 'Type your password here
End Sub

[jaslake]

Hi Fred

Just a few minor changes...

Sub NewUser()
   Dim ws           As Worksheet
   Dim x            As Long
   Dim c            As Long
   Dim d            As Long

   Set ws = ActiveWorkbook.Sheets("MASTER")
   ActiveSheet.Unprotect "PFP1972!"   'Type your password here
   With ws
      d = .Columns("C:C").Find("INITIALS", , xlValues, xlPart, xlByRows, xlNext, False).Row
      If .Cells(d, "D").Value = "" Then
         MsgBox "Enter the New User Information"
         ActiveSheet.Protect "PFP1972!"   'Type your password here
         Exit Sub
      End If

      Application.ScreenUpdating = False
      x = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious).Column

      '      x = .UsedRange.Columns.Count
      .Range(.Cells(2, "B"), .Cells(2, x)).UnMerge
      .Range(.Cells(7, 2), .Cells(7, x)).UnMerge
      c = .Columns("B:C").Find("WEEK TOTALS:", , xlValues, xlPart, xlByRows, xlNext, False).Row - 1
      .Range(.Cells(c, 2), .Cells(c, x)).UnMerge
      .Columns(x - 1).Copy
      .Columns(x - 1).Insert Shift:=xlToRight
      Application.CutCopyMode = False
      .Cells(6, x) = Range("$D$" & d)
   End With

   Sheets("Template").Visible = True
   Application.DisplayAlerts = False
   ActiveWorkbook.Sheets("Template").Copy After:=Sheets(ThisWorkbook.Sheets.Count)
   With ActiveSheet
      .Name = ws.Range("D" & d).Value
      .Cells(1, "B").Value = ws.Range("D" & d + 1).Value
      .Cells(2, "B").Value = ws.Range("D" & d + 2).Value
   End With
   Sheets("Template").Visible = False
   Application.DisplayAlerts = True
   With ws
      .Range("D" & c & ":D" & d + 2).ClearContents
      .Range(.Cells(2, "B"), .Cells(2, x + 1)).Merge
      .Range(.Cells(7, 2), .Cells(7, x + 1)).Merge
      .Range(.Cells(c, 7), .Cells(c, x + 1)).Merge
      .Activate
   End With
   Application.ScreenUpdating = True
   ActiveSheet.Protect "PFP1972!"   'Type your password here
End Sub