Creating worksheets with a macro

Microsoft Excel 2003 (full product)
August 5, 2010 at 15:36:28
Specs: Windows XP
I would really appreciate some help creating a macro. My skills in VB are virtually none.

Basically, my spreadsheet has four columns which contain: Teacher name, student last name, student first name, and column 'd' is just a numerical value.
like this:

BALEY PERRY MARCUS 10
BANNER CASTER CHLOE 1

It is organized alphabetically by teacher and there will be many instances of the same teacher with different students. (i.e. there might be only 13 different teachers but 46 rows)

What I need is a macro that will create and name worksheets based on the teacher names. Then, include the information from columns 'b' 'c' and 'd' for each student only if the numerical value in the 'd' cell is 10 or more.

Also, if I could somehow get the teacher's name as the header of each worksheet, that would be fantastic.

This sounds like a lot of work so thanks in advance for any help I might receive.


See More: Creating worksheets with a macro

Report •

#1
August 9, 2010 at 06:15:54
Hi,

This macro creates a worksheet for each Teacher named in column A (after the headings in row 1)
Only one worksheet per name is created.
Each worksheet has the Teacher's name (from Column A) on row 1
On row 2 is a copy of the headings used for column B, C & D

Each Student with a score of 10 or greater has their first and last names (columns B & C) and column D score copied to the appropriate worksheet.

The macro enters the word "Copied" below the last entry on the source worksheet.

To add more entries to the list, enter them starting on the row below "Copied"

The macro pops-up a message box asking if you want to add data or re-do all data
If Yes is selected to add data, only data below the 'Copied' line is added to the existing data.
If No is selected to re-do all data, all 'Teacher' worksheets are cleared and the data is entered from the start.

I suggest that the macro is run from a button on the worksheet containing the source data.
On the source data worksheet, create a command button from the Control Toolbox toolbar.
(If this isn't visible, right click on an existing toolbar and check the Control Toolbox).
Select the button Icon and draw a button
Right-click the button and select Command Button - Edit and change the name to 'Sort by Teacher' or something else suitable.
Right-click the button again and select View Code
In the code window that opens enter this:

Option Explicit

Private Sub CommandButton1_Click()
'Private Sub Button1_Click()

Dim strResp As String
Dim blnAdd As Boolean
Dim wsSource As Worksheet
Dim wsTest As Worksheet
Dim wsNew As Worksheet
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim strTxt As String
Dim varWsNameArry() As Variant
Dim rngSearch As Range
Dim rngFind As Range
Dim n As Integer

On Error GoTo ErrHnd

'ask if this is a regular 'Add data' or a 'Full Update'
strResp = MsgBox("To add new data to existing data Click 'Yes'" & vbCrLf _
        & "To redo all data Click 'No'" & vbCrLf _
        & "To quit without any update Click 'Cancel'", _
        vbYesNoCancel, _
        "Add new data or Update all data")

'select options
Select Case strResp
    Case vbYes
        blnAdd = True
    Case vbNo
        blnAdd = False
    Case vbCancel
        Exit Sub
End Select

'stop screen updating to increase speed
Application.ScreenUpdating = False

'Setup The source (the calling) worksheet
Set wsSource = ActiveSheet

'resize the array to hold all existing worksheet names
'element 0 is name : element 1 is cleared status
'set to True if not a full update, else False
ReDim varWsNameArry(ActiveWorkbook.Worksheets.Count - 1, 1)
'enter names / cleared status
For n = 0 To ActiveWorkbook.Worksheets.Count - 1
    varWsNameArry(n, 0) = Worksheets(n + 1).Name
    If blnAdd = True Then
        varWsNameArry(n, 1) = True
        Else
        varWsNameArry(n, 1) = False
    End If
Next n

With wsSource
    'set start as row after cell with 'Copied' in it
    'if 'Copied' not found use A2 i.e., after heading row in column A
    Set rngSearch = .Range("A2:A" & CStr(Application.Rows.Count))
    Set rngFind = rngSearch.Find("Copied", LookIn:=xlValues)
    
    If rngFind Is Nothing Or blnAdd = False Then
        'Copied not found - or full update required - start at A2
        Set rngStart = .Range("A2")
        Else
        'Copied found & not a full update
        'set start to row after 'Copied'
        Set rngStart = rngFind.Offset(1, 0)
    End If
    
    'if present, delete row containing 'Copied'
    If Not rngFind Is Nothing Then
        rngFind.EntireRow.Delete
    End If
    
    'set end - last used row in column A
    Set rngEnd = .Range("A" & CStr(Application.Rows.Count)).End(xlUp)
    
    'if full update - clear worksheets before adding any data
    If blnAdd = False Then
        For Each rngCell In .Range(rngStart, rngEnd)
            strTxt = rngCell.Text
            'get worksheet status
            For n = 0 To Worksheets.Count - 1
                If varWsNameArry(n, 0) = strTxt Then
                    'matching worksheet name - test cleared status
                    If varWsNameArry(n, 1) = False Then
                        'clear worksheet
                        Worksheets(strTxt).Cells.Clear
                        'and add headers
                        Worksheets(strTxt).Range("A1") = strTxt
                        .Range("B1:D1").Copy _
                            Destination:=Worksheets(strTxt).Range("A2")
                        'mark worksheet as cleared
                        varWsNameArry(n, 1) = True
                    End If
                End If
            Next n
        Next rngCell
    End If
    
    'add data
    'loop through cells in column A
    For Each rngCell In .Range(rngStart, rngEnd)
        strTxt = rngCell.Text
        'test if tab named with name in column A exists
        On Error Resume Next
        Set wsTest = Worksheets(strTxt)
        On Error GoTo ErrHnd
        If wsTest Is Nothing Then
            'No worksheet of this name - so create one
            'and name it using name in column A
            Set wsNew = Worksheets.Add
            wsNew.Name = strTxt
            'and add headers
            Worksheets(strTxt).Range("A1") = strTxt
            .Range("B1:D1").Copy _
                    Destination:=wsNew.Range("A2")
        End If
        'copy source data to end of existing data
        'if column C value >=10
        If rngCell.Offset(0, 3).Value >= 10 Then
            rngCell.Offset(0, 1).Resize(1, 3).Copy _
                    Destination:=Worksheets(strTxt) _
                    .Range("A" & CStr(Application.Rows.Count)) _
                    .End(xlUp).Offset(1, 0)
        End If
    Next rngCell
    'flag end of copied data (in column A)
    rngEnd.Offset(1, 0).Value = "Copied"
End With

'restore screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'restore screen updating
Application.ScreenUpdating = True
End Sub

Note that Private Sub CommandButton1_Click() and End sub will already be present, so don't duplicate them. Option Explicit goes before Private Sub CommandButton1_Click().
Some lines of code have been split onto two lines for ease of viewing, using the line continuation character "_". This should work 'as is' just copy and paste, or you could remove the "_" and bring the code back to one line.

Click Save from the Visual Basic Menu.

Alt+f11 takes you back to the main Excel window.
Exit design mode (first icon on the Controls Toolbox toolbar).

As changes made by Macros cannot be undone with the Undo button, test this macro on a copy of your data. Always make a backup of your Workbook before running this macro. This code has only been tested on sample data, and it has not been tested in your environment, so test it on copies of your data to ensure that it works 'as expected'

Click the 'Sort by Teacher' button to run the macro

Regards


Report •

#2
August 10, 2010 at 13:01:29
Wow thank you so much.

The macro button did everything I was hoping it would do and more but there is one small snag.

It only worked for the first teacher name in column A. It created one worksheet and then stopped. I am trying to figure out what could be the cause, but as I stated earlier my VB skills are limited.

Once again, thank you very much. This will save me so much time.


Report •

#3
August 10, 2010 at 13:20:57
Hi,

A couple of initial thoughts:
1. Are there any spaces between rows in column A that contain the Teacher names
2. Is it possible that the second teacher's name would not be valid as a Worksheet name.
Can you create a new worksheet and use that name, as the worksheet name.
3. If the above do not give a clue, try changing the last bit of the code to include a message, which might give a hint as to what the macro is looking at when it stops:

'error handler
ErrHnd:
Err.Clear
'restore screen updating
Application.ScreenUpdating = True
MsgBox "Error - rngCell text is:" & vbCrLf & rngCell.Text
End Sub

Regards



Report •

Related Solutions

#4
August 11, 2010 at 16:56:28
Ok I tried what you said.

1. There are no spaces between rows.
2. The name is a valid worksheet name.

This particular spreadsheet has three students listed under the first teacher, so the first three cells in column "A" are the same and the macro creates a worksheet for them. It does not matter what text I enter into the fourth cell, the macro stops creating worksheets after the first one.

3. I now get the message "Error -rngCell text is:" and then it lists whatever text is in the fourth cell (the first cell after the first teacher in column "A"). I can change it and I still get the same error but with different endings. (i.e "Error -rngCell text is: Baker" and then "Error -rngCell text is: 137")


Report •

#5
August 12, 2010 at 04:16:13
Hi,

Can you replace this If ... End If section.
You will see that there are a couple of extra lines, compared to the original:

        If wsTest Is Nothing Then
            'No worksheet of this name - so create one
            'and name it using name in column A
            Set wsNew = Worksheets.Add
            wsNew.Name = strTxt
            'and add headers
            Worksheets(strTxt).Range("A1") = strTxt
            .Range("B1:D1").Copy _
                    Destination:=wsNew.Range("A2")
            Else
            'reset wsTest
            Set wsTest = Nothing
        End If

Regards


Report •

#6
August 12, 2010 at 10:01:48
That worked perfectly, thank you so much for all of your help!

Report •

#7
August 13, 2010 at 04:29:49
You're welcome.

Regards

Humar


Report •

Ask Question