VBA to generate new sheet

[twl2009]

Hi, I need a bit of code that when any text is entered into range A11:G23 if that specific text isnt matched in the range anywhere it creates a new sheet (a copy of sheet2) and names it with the text entered.

Is this possible?

Thanks

 

[twl2009]

Hi Joe

I have added another sub and now this code isnt working at all, Im obviously doing something very stupid, but cant quite figure what.
<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; background-color: #ffffff; min-height: 13.0px}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993; background-color: #ffffff}span.s1 {color: #011993}span.s2 {color: #000000}</style>
Private Sub Worksheet_Change(ByVal Target As Range)


If Target.Address(False, False) = "B2" Then Call TitleCheck


If Target.Address(False, False) = "F2" Then Call DateCheck


End Sub






Private Sub Worksheet_Change(ByVal Target As Range)




Application.ScreenUpdating = False




Dim myRange As Range
Dim isect As Range




If Target.Count > 1 Then Exit Sub




Set myRange = Range("A11:G23")
Set isect = Intersect(Target, myRange)
If isect Is Nothing Then Exit Sub


If Application.WorksheetFunction.CountIf(myRange, Target) = 1 Then
Sheets("Timesheet").Cells.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Name = Target.Value & " Timesheet"
End If


Application.Goto Worksheets("Weekly Labour").Range("A5")




Application.ScreenUpdating = True


End Sub

 

[Joe4]

You can only have one "Worksheet_Change" procedure per sheet!
You would have to combine it into the one, something like this:

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

Dim myRange As Range
Dim isect As Range

If Target.Count > 1 Then Exit Sub

If Target.Address(False, False) = "B2" Then Call TitleCheck

If Target.Address(False, False) = "F2" Then Call DateCheck

Set myRange = Range("A11:G23")
Set isect = Intersect(Target, myRange)
If isect Is Nothing Then Exit Sub

If Application.WorksheetFunction.CountIf(myRange, Target) = 1 Then
    Sheets("Timesheet").Cells.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Name = Target.Value & " Timesheet"
End If

Application.Goto Worksheets("Weekly Labour").Range("A5")

Application.ScreenUpdating = True

End Sub

By the way, if you use Code tags when posting your code, your code will look nicer (like mine!), as long won't lose all the formatting.
Just paste the code, highlight it, and click on the Code tags button from the Editor menu (looks like a hash tag icon).

 

[twl2009]

I will use the code tags in future, thanks.

That code gives me subscript out of range error. It generates the new sheet, but then fails before moving back to sheet 'labour week'

 

[Joe4]

Try changing this line:

Application.Goto Worksheets("Weekly Labour").Range("A5")

to

Sheets("Weekly Labour").Activate
Range("A5").Select

 

[twl2009]

Thanks Joe, ive changed it now so it returns to next cell. Pretty pleased that I managed to do something for myself for once.
However I was thinking about trying to get the sheets removed when the text is removed. The Stackoverflow suggestion of having a hidden sheet, so that when new text (actually names) is entered it adds it to hidden sheet ('staff'). Then if the names in the range A11:G23 dont match the names on the hidden sheet it deletes the sheet matching the missing name.
does that make any sense and would it be possible.??

 

[Joe4]

I think I would look at the two suggestions above that one. The one just above it looks promising.

 

[twl2009]

Ok cool. I will try and get my head around how to use one of the methods suggested. At the moment I'm struggling to get myrange to be multiple ranges.

<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #000000; background-color: #ffffff}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; background-color: #ffffff; min-height: 13.0px}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993; background-color: #ffffff}span.s1 {color: #011993}span.s2 {color: #000000}</style>Private Sub Worksheet_Change(ByVal Target As Range)




Application.ScreenUpdating = False




Dim r1, r2, r3, r4, myMultipleRange As Range
Dim isect As Range




If Target.Count > 1 Then Exit Sub




If Target.Address(False, False) = "B2" Then Call TitleCheck




If Target.Address(False, False) = "F2" Then Call DateCheck


Set r1 = .Range("A11:G23")
Set r2 = .Range("A26:G34")
Set r3 = .Range("A38:G46")
Set r4 = .Range("A50:G58")
Set myMultipleRange = Application.Union(r1, r2, r3, r4)
Set isect = Intersect(Target, myMultipleRange)
If isect Is Nothing Then Exit Sub




If Application.WorksheetFunction.CountIf(myMultipleRange, Target) = 1 Then
    Set MyActiveCell = ActiveCell
    Sheets("Timesheet").Cells.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Name = Target.Value & " Timesheet"
End If


Sheets("Labour Week").Activate
MyActiveCell.Select


Application.ScreenUpdating = True




[COLOR=#011993][FONT=Menlo]End[/FONT][/COLOR][FONT=Menlo] [/FONT][COLOR=#011993][FONT=Menlo]Sub[/FONT][/COLOR]/CODE]

 

[Joe4]

One thing that stands out at first glance is the periods in front of your range. Remove those. You would only do that within a With statement, i.e.

[COLOR=#333333]Set r1 = Range("A11:G23")[/COLOR]
[COLOR=#333333]Set r2 = Range("A26:G34")[/COLOR]
[COLOR=#333333]Set r3 = Range("A38:G46")[/COLOR]
[COLOR=#333333]Set r4 = Range("A50:G58")[/COLOR]

 

[twl2009]

Sorry Joe that was a mistake copy and pasting. I was just trying out the "."s to see if that would work. Unfortunately doesnt work without the "."s either.

 

[Joe4]

It seemed to work fine for me.
What cell did you try typing something in to?