Create new sheets from data in either of two columns
 

I am a novice excel user but need help with a macro. I have a
spreadsheet with 21 columns A to U on sheet 1. I would like if
information is entered into column C or column F the row, Column A to
U would be copied to new sheet with name of the data found in either
column C or F. If the name sheet already rewrite to the named sheet.
The header row is A2 to U2
Data is in A3:U382
There will be a maximum of twenty different text values in the C and F
columns.

Create new sheets from data in either of two columns
 

Right-click the main sheet tab. Select View Code. Paste the following code
there. Test to see if you get the results you expect. You may want to use a
duplicate copy of your workbook so as not to imperil real data.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim wksThisSheet As Worksheet
Set wksThisSheet = ActiveSheet
Application.ScreenUpdating = False
If Not Intersect(Target, Range("C3:C382")) Is Nothing Then
If Not WorksheetExists(Range("C2").Text) Then
Set wks = Worksheets.Add(, Worksheets(Sheets.Count))
wks.Name = Range("C2").Text
End If
Intersect(Rows(Target.Row), Range("A:U")).Copy
Worksheets(Range("C2").Text).Rows(Target.Row)
ElseIf Not Intersect(Target, Range("F3:F382")) Is Nothing Then
If Not WorksheetExists(Range("F2").Text) Then
Set wks = Worksheets.Add(, Worksheets(Sheets.Count))
wks.Name = Range("F2").Text
End If
Intersect(Rows(Target.Row), Columns("A:U")).Copy
Worksheets(Range("F2").Text).Rows(Target.Row)
End If
wksThisSheet.Activate
Application.ScreenUpdating = True
End Sub

Private Function WorksheetExists(SheetName As String) As Boolean
Dim wks As Worksheet
WorksheetExists = False
For Each wks In Worksheets
If LCase(wks.Name) = LCase(SheetName) Then
WorksheetExists = True
Exit Function
End If
Next wks
End Function



<Campbell wrote in message
...
I am a novice excel user but need help with a macro. I have a
spreadsheet with 21 columns A to U on sheet 1. I would like if
information is entered into column C or column F the row, Column A to
U would be copied to new sheet with name of the data found in either
column C or F. If the name sheet already rewrite to the named sheet.
The header row is A2 to U2
Data is in A3:U382
There will be a maximum of twenty different text values in the C and F
columns.

Create new sheets from data in either of two columns
 

Slightly simplified version of previous post:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wksThisSheet As Worksheet
Set wksThisSheet = ActiveSheet
Application.ScreenUpdating = False
If Not Intersect(Target, Range("C3:C382")) Is Nothing Then
If Not WorksheetExists(Range("C2").Text) Then _
Worksheets.Add(, Worksheets(Sheets.Count)).Name = _
Range("C2").Text
Intersect(Rows(Target.Row), Range("A:U")).Copy
Worksheets(Range("C2").Text).Rows(Target.Row)
ElseIf Not Intersect(Target, Range("F3:F382")) Is Nothing Then
If Not WorksheetExists(Range("F2").Text) Then _
Worksheets.Add(, Worksheets(Sheets.Count)).Name = _
Range("F2").Text
Intersect(Rows(Target.Row), Columns("A:U")).Copy
Worksheets(Range("F2").Text).Rows(Target.Row)
End If
wksThisSheet.Activate
Application.ScreenUpdating = True
End Sub

Private Function WorksheetExists(SheetName As String) As Boolean
Dim wks As Worksheet
WorksheetExists = False
For Each wks In Worksheets
If LCase(wks.Name) = LCase(SheetName) Then
WorksheetExists = True
Exit Function
End If
Next wks
End Function

"Bob Kilmer" wrote in message
...
Right-click the main sheet tab. Select View Code. Paste the following code
there. Test to see if you get the results you expect. You may want to use
a
duplicate copy of your workbook so as not to imperil real data.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim wksThisSheet As Worksheet
Set wksThisSheet = ActiveSheet
Application.ScreenUpdating = False
If Not Intersect(Target, Range("C3:C382")) Is Nothing Then
If Not WorksheetExists(Range("C2").Text) Then
Set wks = Worksheets.Add(, Worksheets(Sheets.Count))
wks.Name = Range("C2").Text
End If
Intersect(Rows(Target.Row), Range("A:U")).Copy
Worksheets(Range("C2").Text).Rows(Target.Row)
ElseIf Not Intersect(Target, Range("F3:F382")) Is Nothing Then
If Not WorksheetExists(Range("F2").Text) Then
Set wks = Worksheets.Add(, Worksheets(Sheets.Count))
wks.Name = Range("F2").Text
End If
Intersect(Rows(Target.Row), Columns("A:U")).Copy
Worksheets(Range("F2").Text).Rows(Target.Row)
End If
wksThisSheet.Activate
Application.ScreenUpdating = True
End Sub

Private Function WorksheetExists(SheetName As String) As Boolean
Dim wks As Worksheet
WorksheetExists = False
For Each wks In Worksheets
If LCase(wks.Name) = LCase(SheetName) Then
WorksheetExists = True
Exit Function
End If
Next wks
End Function



<Campbell wrote in message
...
I am a novice excel user but need help with a macro. I have a
spreadsheet with 21 columns A to U on sheet 1. I would like if
information is entered into column C or column F the row, Column A to
U would be copied to new sheet with name of the data found in either
column C or F. If the name sheet already rewrite to the named sheet.
The header row is A2 to U2
Data is in A3:U382
There will be a maximum of twenty different text values in the C and F
columns.

Create new sheets from data in either of two columns
 

On Sat, 14 Aug 2004 23:36:02 -0400, "Bob Kilmer"
wrote:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wksThisSheet As Worksheet
Set wksThisSheet = ActiveSheet
Application.ScreenUpdating = False
If Not Intersect(Target, Range("C3:C382")) Is Nothing Then
If Not WorksheetExists(Range("C2").Text) Then _
Worksheets.Add(, Worksheets(Sheets.Count)).Name = _
Range("C2").Text
Intersect(Rows(Target.Row), Range("A:U")).Copy
Worksheets(Range("C2").Text).Rows(Target.Row)
ElseIf Not Intersect(Target, Range("F3:F382")) Is Nothing Then
If Not WorksheetExists(Range("F2").Text) Then _
Worksheets.Add(, Worksheets(Sheets.Count)).Name = _
Range("F2").Text
Intersect(Rows(Target.Row), Columns("A:U")).Copy
Worksheets(Range("F2").Text).Rows(Target.Row)
End If
wksThisSheet.Activate
Application.ScreenUpdating = True
End Sub

Private Function WorksheetExists(SheetName As String) As Boolean
Dim wks As Worksheet
WorksheetExists = False
For Each wks In Worksheets
If LCase(wks.Name) = LCase(SheetName) Then
WorksheetExists = True
Exit Function
End If
Next wks
End Function
Bob thanks for your macros ,but I am having a problem with where as
when I right click on the tab paste the macro I get a Macro dialogue
box asking a for a name to be entered.
When I try F8 to step through the code it will not permit me to do so.

Any ideas?

Create new sheets from data in either of two columns
 

Hmmm...
I am able to:
1. Copy the code from Option Explicit to End Function (inclusive)
2. Open a new workbook.
3. Right click on any sheet tab (Sheet1, for instance).
4. Select all (press Ctrl+A) (The only text you'll see is "Option
Explicit.")
5. Right-click ON the selection.
6. Choose Paste.
This should paste the code into the module.

I am using Excel 2002 on Windows 2K Pro.
Try the above steps as stated and let me know how it turns out. I am not
familiar with a macro dialog poping up as you describe.

Bob

<Campbell wrote in message
...
On Sat, 14 Aug 2004 23:36:02 -0400, "Bob Kilmer"
wrote:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wksThisSheet As Worksheet
Set wksThisSheet = ActiveSheet
Application.ScreenUpdating = False
If Not Intersect(Target, Range("C3:C382")) Is Nothing Then
If Not WorksheetExists(Range("C2").Text) Then _
Worksheets.Add(, Worksheets(Sheets.Count)).Name = _
Range("C2").Text
Intersect(Rows(Target.Row), Range("A:U")).Copy
Worksheets(Range("C2").Text).Rows(Target.Row)
ElseIf Not Intersect(Target, Range("F3:F382")) Is Nothing Then
If Not WorksheetExists(Range("F2").Text) Then _
Worksheets.Add(, Worksheets(Sheets.Count)).Name = _
Range("F2").Text
Intersect(Rows(Target.Row), Columns("A:U")).Copy
Worksheets(Range("F2").Text).Rows(Target.Row)
End If
wksThisSheet.Activate
Application.ScreenUpdating = True
End Sub

Private Function WorksheetExists(SheetName As String) As Boolean
Dim wks As Worksheet
WorksheetExists = False
For Each wks In Worksheets
If LCase(wks.Name) = LCase(SheetName) Then
WorksheetExists = True
Exit Function
End If
Next wks
End Function
Bob thanks for your macros ,but I am having a problem with where as
when I right click on the tab paste the macro I get a Macro dialogue
box asking a for a name to be entered.
When I try F8 to step through the code it will not permit me to do so.

Any ideas?

Create new sheets from data in either of two columns
 

On Sun, 15 Aug 2004 20:15:15 -0400, "Bob Kilmer"
wrote:

Hmmm...
I am able to:
1. Copy the code from Option Explicit to End Function (inclusive)
2. Open a new workbook.
3. Right click on any sheet tab (Sheet1, for instance).
4. Select all (press Ctrl+A) (The only text you'll see is "Option
Explicit.")
5. Right-click ON the selection.
6. Choose Paste.
This should paste the code into the module.

I am using Excel 2002 on Windows 2K Pro.
Try the above steps as stated and let me know how it turns out. I am not
familiar with a macro dialog poping up as you describe.

Bob

Bob,
For some reason in the VB Tools --- Options the Require
Variable Declaration was unchecked.

I am having limited success with this code, where it has created
additional the two sheets which is the name of the two header columns.
There is no data in the two newly created sheets however.
In my original post I said that it was Column C however it is Column
D, so I changed all the references C to D. Plus I got rid of a some
blank columns So it is now A:Q , all the amended are in lower case.

Columns D and F already have the text data completed and this will not
change.
Columns E and G are numerical data inputted manually periodically.
What I is the data from D3:D382 and F3:F382 to be their own sheets

e.g A B C D E F G
2 Time Date Gr NM1 HiS NM2 AiS
3 Thomas Lloyd
4 Austin Samuel
13 Samuel Bilton
20 Newton Thomas

So from the example Thomas, Lloyd, Austin, Samuel, Bilton, Newton will
all have their sheets.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim wksThisSheet As Worksheet
Set wksThisSheet = ActiveSheet
Application.ScreenUpdating = False
If Not Intersect(Target, Range("d3:d382")) Is Nothing Then
If Not WorksheetExists(Range("d2").Text) Then
Set wks = Worksheets.Add(, Worksheets(Sheets.Count))
wks.Name = Range("d2").Text
End If
Intersect(Rows(Target.Row), Range("A:q")).Copy
Worksheets(Range("d2").Text).Rows(Target.Row)
ElseIf Not Intersect(Target, Range("F3:F382")) Is Nothing Then
If Not WorksheetExists(Range("F2").Text) Then
Set wks = Worksheets.Add(, Worksheets(Sheets.Count))
wks.Name = Range("F2").Text
End If
Intersect(Rows(Target.Row), Columns("A:q")).Copy
Worksheets(Range("F2").Text).Rows(Target.Row)
End If
wksThisSheet.Activate
Application.ScreenUpdating = True
End Sub

Private Function WorksheetExists(SheetName As String) As Boolean
Dim wks As Worksheet
WorksheetExists = False
For Each wks In Worksheets
If LCase(wks.Name) = LCase(SheetName) Then
WorksheetExists = True
Exit Function
End If
Next wks
End Function

Create new sheets from data in either of two columns
 

3a. Select View Code.

"Bob Kilmer" wrote in message
...
Hmmm...
I am able to:
1. Copy the code from Option Explicit to End Function (inclusive)
2. Open a new workbook.
3. Right click on any sheet tab (Sheet1, for instance).
4. Select all (press Ctrl+A) (The only text you'll see is "Option
Explicit.")
5. Right-click ON the selection.
6. Choose Paste.
This should paste the code into the module.

I am using Excel 2002 on Windows 2K Pro.
Try the above steps as stated and let me know how it turns out. I am not
familiar with a macro dialog poping up as you describe.

Bob

<Campbell wrote in message
...
On Sat, 14 Aug 2004 23:36:02 -0400, "Bob Kilmer"
wrote:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wksThisSheet As Worksheet
Set wksThisSheet = ActiveSheet
Application.ScreenUpdating = False
If Not Intersect(Target, Range("C3:C382")) Is Nothing Then
If Not WorksheetExists(Range("C2").Text) Then _
Worksheets.Add(, Worksheets(Sheets.Count)).Name = _
Range("C2").Text
Intersect(Rows(Target.Row), Range("A:U")).Copy
Worksheets(Range("C2").Text).Rows(Target.Row)
ElseIf Not Intersect(Target, Range("F3:F382")) Is Nothing Then
If Not WorksheetExists(Range("F2").Text) Then _
Worksheets.Add(, Worksheets(Sheets.Count)).Name = _
Range("F2").Text
Intersect(Rows(Target.Row), Columns("A:U")).Copy
Worksheets(Range("F2").Text).Rows(Target.Row)
End If
wksThisSheet.Activate
Application.ScreenUpdating = True
End Sub

Private Function WorksheetExists(SheetName As String) As Boolean
Dim wks As Worksheet
WorksheetExists = False
For Each wks In Worksheets
If LCase(wks.Name) = LCase(SheetName) Then
WorksheetExists = True
Exit Function
End If
Next wks
End Function
Bob thanks for your macros ,but I am having a problem with where as
when I right click on the tab paste the macro I get a Macro dialogue
box asking a for a name to be entered.
When I try F8 to step through the code it will not permit me to do so.

Any ideas?