How can I check spreadsheets in multiple subfolders then filter on user criteria

[Dischordant]

Hi guys - I work as a Secondary school teacher and we have a spreadsheet for each teacher with all our classes on it and the students names for each class.

In this spreadsheet we can mark on whether a student is struggling with progress or behaviour and what we are doing to address it. Each department then has a Summary spreadsheet that pulls out any students who are having trouble in their department so the Head of department can keep an overview.

What I'd like to now create is a spreadsheet the head of year/key stage can use that will ask them the year group of the student they are interested in and how many amber or red flags they want to look for. (E.g. students in Year 7 who have over 4 subjects listed with an R).

The spreadsheet it would need to check are each in a departmental folder.

E.g.

\\Student Monitoring\Head of Year-KeyStage Spreadsheet.xlsx

\\Student Monitoring\ICT\IT Summary Spreadsheet.xlsx

\\Student Monitoring\PE\PE Summary Spreadsheet.xlsx

\\Student Monitoring\English\English Summary Spreadsheet.xlsx

...etc.

There are about 14 different subject areas it would be pulling from.

What is the simplest way for me to achieve this please?

Many thanks for any and all help!

Darren

[xladept]

If the Spreadsheets are in the same folder, then your best bet is to "run the directory" - but, for us to write a routine for you, we'd need an Example Sheet - hopefully they're all formatted similarly!!

[Dischordant]

Thank you Xladept - Can I post an example of 2 of the spreadsheets here or do I need to host them?

[xladept]

You can post them here - go to advanced and click on the paper-clip icon.

[Dischordant]

Music Department Summary.xlsmScience Department Summary.xlsmPS.xlsx

Please allow me to apologise for the inelegant way this system is created - if it were up to me it would all be in a database but this was how it was requested and my excel knowledge is so lacking I did what I could =p

The summary sheets already accumulate all of the teachers students who are of concern successfully so I then just need to be able to check for a name appearing in more than one (dependent on criteria chosen) of the department checklists.

E.g. SMITH John has been misbehaving in two of his subjects - therefore on the proposed spreadsheet when a drop down is set to "2" it would return the comments from both those subjects for SMITH John (and any other students with 2 or more Red).

Thank you!!

Darren

[xladept]

Hi DisChordant,

'What I'd like to now create is a spreadsheet the head of year/key stage can use
'that will ask them the year group of the student they are interested in
'and how many amber or red flags they want to look for.
'(E.g. students in Year 7 who have over 4 subjects listed with an R).

Sub DisChord(): Dim SYear As Integer, Flags As String, SName As String, n As Integer
Dim wb As Workbook, ws As Worksheet, wd As Workbook, wc As Worksheet
Dim r As Long, f As Long, i As Long, j As Long, S As String, P As String, U As String:

P = ActiveWorkbook.Path & "\": U = Dir(P)

SYear = Val(InputBox("Student Year Group?"))
Flags = _
InputBox(" Type #, RAO for Number of Flags Red - Amber or Outstanding (Inclusive)")
i = InStr(1, Flags, ","): n = Left(Flags, i - 1)

Set wd = Workbooks("DisChordant") 'The Summary Book Name goes here in the same folder as the others

SetaBook:
If U = wd.Name Then GoTo GetaBook
If InStr(1, U, ".xl") = 0 Then GoTo GetaBook

If InStr(1, U, "Department Summary") Then
Workbooks.Open fileName:=P & U, UpdateLinks:=0
Set wb = ActiveWorkbook: Set ws = wb.Sheets("Sheet1")

If InStr(1, Flags, "O") Then
Set wc = wd.Sheets("Outstanding"): r = GetLine(wc)
ws.Range("A779:U1207").Copy
wc.Range("A" & r).PasteSpecial xlPasteValues: End If

If InStr(1, Flags, "A") Then
Set wc = wd.Sheets("Amber"): r = GetLine(wc)
ws.Range("A405:U777").Copy
wc.Range("A" & r).PasteSpecial xlPasteValues: End If

If InStr(1, Flags, "R") Then
Set wc = wd.Sheets("Red"): r = GetLine(wc)
ws.Range("A3:U403").Copy
wc.Range("A" & r).PasteSpecial xlPasteValues: End If

Application.DisplayAlerts = False
wb.Close SaveChanges:=False
End If
GetaBook: U = Dir()        'Get another book
If U = "" Then GoTo Sorts
GoTo SetaBook

Sorts:
S = wd.Name
Set wc = wd.Sheets("Compilation")

If InStr(1, Flags, "R") Then
r = GetLine(wd.Sheets("Red"))
wd.Sheets("Red").Range("A2:U" & r).Copy
r = GetLine(wc)
wc.Range("A" & r).PasteSpecial xlPasteAll: End If

If InStr(1, Flags, "A") Then
r = GetLine(wd.Sheets("Amber"))
wd.Sheets("Amber").Range("A2:U" & r).Copy
r = GetLine(wc)
wc.Range("A" & r).PasteSpecial xlPasteAll: End If

If InStr(1, Flags, "O") Then
r = GetLine(wd.Sheets("Outstanding"))
wd.Sheets("Outstanding").Range("A2:U" & r).Copy
r = GetLine(wc)
wc.Range("A" & r).PasteSpecial xlPasteAll: End If

r = GetLine(wc)

SortandLoop:
wc.Range("A1:A" & r).Sort Key1:=wc.Range("A2"), _
Order1:=xlAscending, Header:=xlYes

                SName = wc.Range("A2")
For i = 2 To r
InLoop:
If wc.Cells(i, 2) = SYear And wc.Cells(i, 1) = SName Then
f = f + 1: i = i + 1: GoTo InLoop: End If

Commentary:
If f >= Flags Then
r = GetLine(wd.Sheets("Sheet1")): wd.Sheets("Sheet1").Cells(r, 1) = SName
wc.Cells(i - j, 18).Copy wd.Sheets("Sheet1").Cells(r, 3 + f)
f = f - 1: j = j + 1: GoTo Commentary: End If
j = 0: r = r + 1: SName = wc.Cells(i + 1, 1)
GetNext: Next i

End Sub

Function GetLine(C As Worksheet) As Long
GetLine = C.Range("A" & Rows.Count).End(xlUp).row + 1: End Function

'I was unable to test the whole routine since I couldn't update the source sheets
'But if you want to send me some Departrment Summary test data, I'll follow through


P.S. The Summary book has 4 extra sheets: Compilation, Red, Amber, Outstanding each with Headers - I'll Attach an example

DisChordant.xlsm

[xladept]

Hi again,

I made up some test data and now it seems to be working - try this:

Sub DisChord(): Dim SYear As Integer, Flags As String, SName As String, n As Integer
Dim wb As Workbook, ws As Worksheet, wd As Workbook, wc As Worksheet
Dim r As Long, f As Long, i As Long, j As Long, S As String, P As String, U As String:

P = ActiveWorkbook.Path & "\": U = Dir(P)

SYear = Val(InputBox("Student Year Group?"))
Flags = _
InputBox(" Type #, RAO for Number of Flags Red - Amber or Outstanding (Inclusive)")
i = InStr(1, Flags, ","): n = Left(Flags, i - 1)

Set wd = Workbooks("DisCord") 'The Summary Book Name goes here in the same folder as the others

SetaBook:
If U = wd.Name Then GoTo GetaBook
If InStr(1, U, ".xl") = 0 Then GoTo GetaBook

If InStr(1, U, "Department Summary") Then
Workbooks.Open Filename:=P & U, UpdateLinks:=0
Set wb = ActiveWorkbook: Set ws = wb.Sheets("Sheet1")

If InStr(1, Flags, "O") Then
Set wc = wd.Sheets("Outstanding"): r = GetLine(wc)
ws.Range("A779:U1207").Copy
wc.Range("A" & r).PasteSpecial xlPasteValues: End If

If InStr(1, Flags, "A") Then
Set wc = wd.Sheets("Amber"): r = GetLine(wc)
ws.Range("A405:U777").Copy
wc.Range("A" & r).PasteSpecial xlPasteValues: End If

If InStr(1, Flags, "R") Then
Set wc = wd.Sheets("Red"): r = GetLine(wc)
ws.Range("A3:U403").Copy
wc.Range("A" & r).PasteSpecial xlPasteValues: End If

Application.DisplayAlerts = False
wb.Close SaveChanges:=False
End If
GetaBook: U = Dir()        'Get another book
If U = "" Then GoTo Sorts
GoTo SetaBook

Sorts:
S = wd.Name
Set wc = wd.Sheets("Compilation")

If InStr(1, Flags, "R") Then
r = GetLine(wd.Sheets("Red"))
wd.Sheets("Red").Range("A2:U" & r).Copy
r = GetLine(wc)
wc.Range("A" & r).PasteSpecial xlPasteAll: End If

If InStr(1, Flags, "A") Then
r = GetLine(wd.Sheets("Amber"))
wd.Sheets("Amber").Range("A2:U" & r).Copy
r = GetLine(wc)
wc.Range("A" & r).PasteSpecial xlPasteAll: End If

If InStr(1, Flags, "O") Then
r = GetLine(wd.Sheets("Outstanding"))
wd.Sheets("Outstanding").Range("A2:U" & r).Copy
r = GetLine(wc)
wc.Range("A" & r).PasteSpecial xlPasteAll: End If

r = GetLine(wc)

SortandLoop:
wc.Activate
wc.Range("A2:U" & r).Sort Key1:=Range("B2"), Order1:=xlDescending
wc.Range("A2:U" & r).Sort Key1:=Range("A2"), Order1:=xlAscending

                SName = wc.Range("A2")
For i = 2 To r: f = 0
InLoop:
If wc.Cells(i, 2) = SYear And wc.Cells(i, 1) = SName Then
f = f + 1: i = i + 1: GoTo InLoop: End If


If f >= n Then
r = GetLine(wd.Sheets("Sheet1")): wd.Sheets("Sheet1").Cells(r, 1) = SName
Commentary:
If f Then
wc.Cells(i - j, 18).Copy wd.Sheets("Sheet1").Cells(r, 3 + f)
f = f - 1: j = j + 1: GoTo Commentary: End If: End If
j = 0: SName = wc.Cells(i + 1, 1)
GetNext: Next i

End Sub

I don't unhide the rows in the summaries, it's unnecessary - here's discord Discord.xlsm



Since the posting above - I've fine tuned the program - this is the latest version:Discord.xlsm