Using VBA in Excel macro to extract data from table and reconstruct table

Here is an interesting 'real-world' school based problem.


There are about 250 students in a year group who generally take ten subjects so there are 2500 rows in a table for each year group. Each row includes the subject/class name/teacher name and the student’s target in that subject. I need to be able to export a spreadsheet for each teacher that will enable them to change targets (in a separate column). I need a save option that will enable that teachers spreadsheet to paste into a master sheets basically re-compiling the master with all the teacher changes.


So, I think the process is:
- Copy / paste the teacher name column on the table and remove duplicates so that you have a list of all the teachers.
- For each teacher name in this list:
o Filter the table to display that teachers student/ subject/ class
o Copy into a new sheet, a few rows down to allow for some summary formulas and heading to be added
o Add some formula columns to the right of the table (but with the same number of rows)
o Give the records (not the headings) a range name identify the teacher
o Save with a file name that identifies the teacher and year group
- Provide a separate Save button for the user such that when pressed the records which are part of the table are copied over the records which already exist in the master.


That’s the idea.


I have some spreadsheet of dummy data you can work with if you want to take a closer look
1. Dummy Data
2. Example of the data I want to export for one teacher (called Target Review Year 10 Teacher#20)
3. Example of a reconstructed table (called 3 Recompiled)


Good luck and all help appreciated

How can I get the revised data from Dummydata book?

Try this , Note I have commented out saving the workbook because I didn't want loads of workbooks saved on my machine,

Code:

---

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

---