Sub copydata()With Worksheets("Sheet1")
Dim teachername As String
Dim outarr As Variant
' double quotes string
tt = Chr(34)
teachername = "9999"
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(.Cells(1, 1), .Cells(lastrow, 6))
End With
For i = 2 To lastrow
If inarr(i, 5) <> "" Then
If teachername <> inarr(i, 5) Then
If teachername <> "9999" Then
outarr(1, 1) = "Target Review " & inarr(i, 2) & " " & teachername
outarr(3, 1) = "High"
outarr(4, 1) = "Middle"
outarr(5, 1) = "Low"
Range(Cells(1, 1), Cells(lastrow + 7, 6)) = outarr
'=COUNTIFS(G$7:G$1198,">0",A$7:A$1198,A3)
Cells(3, 2).Formula = "=countifs(G$7:g$" & indi & "," & tt & ">0" & tt & ",A$7:A$" & indi & ",A3)"
Cells(4, 2).Formula = "=countifs(G$7:g$" & indi & "," & tt & ">0" & tt & ",A$7:A$" & indi & ",A4)"
Cells(5, 2).Formula = "=countifs(G$7:g$" & indi & "," & tt & ">0" & tt & ",A$7:A$" & indi & ",A5)"
Cells(3, 7).Formula = "=countifs(G$7:g$" & indi & "," & tt & ">0" & tt & ")"
Cells(3, 8).Formula = "=Sum(H$7:H$" & indi & ")"
Cells(7, 7) = "Revised"
Cells(7, 8) = "Changed"
' ActiveWorkbook.SaveAs "C:\tmp\" & teachername & ".xls"
End If
teachername = inarr(i, 5)
Workbooks.Add
outarr = Range(Cells(1, 1), Cells(lastrow + 7, 6))
For j = 1 To 6
' copy the headings
outarr(7, j) = inarr(1, j)
Next j
indi = 8
' copy a line of data
For j = 1 To 6
outarr(indi, j) = inarr(i, j)
Next j
'delete the name because we have done it.
inarr(i, 5) = ""
indi = indi + 1
End If
' go and check the rest of the list for the same teacher
For k = i To lastrow
If teachername = inarr(k, 5) Then
' copy a line of data
For j = 1 To 6
outarr(indi, j) = inarr(k, j)
Next j
inarr(k, 5) = ""
indi = indi + 1
End If
Next k
End If
Next i
End Sub