Subscript Out Of Range

[AngelK]

Hello,

I'm new to VB, and cannot get my code to do what I need. I'm using Excel2013. My workbook has one sheet (Sheet1), with columns A - K, and 307 rows (one row per student). Column H is a teachers name. I need my code to create new sheets for each teacher (col H), and copy all student's data (col A:K) to the new sheet who have the same teacher. This would loop through all 307 rows of students. Essentially taking a large class list, and parsing it out by teacher.

I am getting a "subscript out of range" on this line: Sheets(strDestinationSheet).Visible = True

Here is my full code:

Sub ImportToTeacherLists()
Dim strSourceSheet As String
Dim strDestinationSheet As String
Dim lastRow As Long

strSourceSheet = "Sheet1"

Sheets(strSourceSheet).Visible = True
Sheets(strSourceSheet).Select

Range("h2").Select
Do While ActiveCell.Value <> ""
strDestinationSheet = ActiveCell.Value
Selection.Copy
ActiveCell.Offset(0, 0).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select
Selection.Copy

Sheets(strDestinationSheet).Visible = True
Sheets(strDestinationSheet).Select

lastRow = Sheets(strDestinationSheet).Range("h2").End(xlDown).Row
Cells(lastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Sheets(strSourceSheet).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub

Thank you for your help.

 

[shg]

Welcome to the board.

That means there is no sheet in the active workbook whose name is the value of strDestinationSheet. It cannot mean anything else.

 

[Michael M]

Also, make sure the active cell

strDestinationSheet = ActiveCell.Value

does not contain any blanks, or non allowable characters for sheet names !!

 

[wideboydixon]

Commented code below. Hope I got it right.

Public Sub ImportToTeacherLists()

Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRows As New Collection
Dim teacherName As String
Dim lastRow As Long
Dim thisRow As Long
Dim targetRow As Long

On Error Resume Next

' Assume we're starting with the teacher sheet
Set sourceSheet = ActiveSheet

' Find the last row in the source sheet
With sourceSheet
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With

' Loop through the rows
For thisRow = 2 To lastRow
    ' Get the teacher name
    teacherName = sourceSheet.Cells(thisRow, 8).Value
    
    ' Try and get the sheet for this teacher
    Err.Clear
    Set targetSheet = Worksheets(teacherName)
    
    ' Check error return
    If Err.Number <> 0 Then
        ' Sheet not found - we've not created it yet so do it now and set the name
        Set targetSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        targetSheet.Name = teacherName
        
        ' Copy the headers from the source sheet
        sourceSheet.Range("A1:K1").Copy Destination:=targetSheet.Range("A1")
        
        ' Add to the collection
        lastRows.Add 2, teacherName
        
        ' Set the target row
        targetRow = 2
    Else
        ' Get the target row
        targetRow = lastRows.Item(teacherName)
    End If
    
    ' Copy this line across
    sourceSheet.Cells(thisRow, 1).Resize(, 11).Copy Destination:=targetSheet.Cells(targetRow, 1)
    
    ' Increment the target row and update the collection
    targetRow = targetRow + 1
    lastRows.Remove teacherName
    lastRows.Add targetRow, teacherName
Next thisRow

End Sub

WBD

 

[AngelK]

Thank you to everyone for the quick response. This code worked perfectly. Saved me another day of frustration! I appreciate all of your help. Have a great weekend!