VBA Multiple sheet Collation

[mwillerton]

Hi

I am experienced with Excel but my programming is very bad!
I have a excel 2007 workbook that records assessment grades and exam entries on multiple sheets. Each sheet is named according to class group. I want some VBA code that will read the sheet names, collate them to a new sheet and extract data from specific cells in each sheet and record it in the newly created sheet in new columns.
I have found this code that creates sheets, however it records it in a single set of cells.

Sub Macro1a()
Dim SecStat As Worksheet
Dim R As Long
Dim strName As String
Dim Wks As Worksheet
'Add the sheet if needed or use the existing one.
On Error Resume Next
Set SecStat = Worksheets("Section Statistics")
If Err > 0 Then
Set SecStat = Worksheets.add(After:=Worksheets(Worksheets.Count))
ActiveSheet.Name = "Section Statistics"
R = 1
Else
R = SecStat.UsedRange.Rows.Count
End If
On Error GoTo 0


For Each Wks In Worksheets
If Wks.Name <> SecStat.Name Then
strName = Wks.Name & Wks.Range("D34")
SecStat.Range("A1").Offset(R, 0) = strName
R = R + 1
End If
Next Wks

End Sub

This only collates sheet names and records a single cell. I need to select data from multiple cells and record in the sheet.


I have added in the sheets i am working on

Your Download-Link:FS Tracking Sheet MW Version 1.0.xlsm
http://www.megafileupload.com/en/file/320295/FS-Tracking-Sheet-MW-Version-1-0-xlsm.html

Thanks for help

Matt

 

[Comfy]

And what data do need extracting to the new sheet?

 

[mwillerton]

And what data do need extracting to the new sheet?

I am looking at collating totals recorded from each sheet. IE numbers of students from each, number of passes from each sheet, number of entrants on each sheet. etc. etc. Enough for complete statistics from each sheet created.

 

[Comfy]

I think I understand what you need, let me know if I'm close or not.

Sub Macro1a()

  Dim SecStat As Worksheet
  Dim R As Long
  Dim strName As String
  Dim Wks As Worksheet

   'Add the sheet if needed or use the existing one.
    On Error Resume Next
      Set SecStat = Worksheets("Section Statistics")
      If Err > 0 Then
         Set SecStat = Worksheets.add(After:=Worksheets(Worksheets.Count))
         ActiveSheet.Name = "Section Statistics"
         Cells(1, 2).Value = "Total in Group"
         Cells(1, 3).Value = "English Entered"
         Cells(1, 4).Value = "English Passed"
         R = 1
      Else
         R = SecStat.UsedRange.Rows.Count
      End If
    On Error GoTo 0
    
    
    For Each Wks In Worksheets
      If Wks.Name <> SecStat.Name And Wks.Name <> "Data" And Wks.Name <> "Original" Then
         SecStat.Range("A1").Offset(R, 0) = Wks.Name
         SecStat.Range("A1").Offset(R, 1) = Wks.Range("D34")
         SecStat.Range("A1").Offset(R, 2) = Wks.Range("I75")
         SecStat.Range("A1").Offset(R, 3) = Wks.Range("I77")
         R = R + 1
      End If
    Next Wks
    
End Sub

 

[mwillerton]

I think I understand what you need, let me know if I'm close or not.

Sub Macro1a()
 
  Dim SecStat As Worksheet
  Dim R As Long
  Dim strName As String
  Dim Wks As Worksheet
 
   'Add the sheet if needed or use the existing one.
    On Error Resume Next
      Set SecStat = Worksheets("Section Statistics")
      If Err > 0 Then
         Set SecStat = Worksheets.add(After:=Worksheets(Worksheets.Count))
         ActiveSheet.Name = "Section Statistics"
         Cells(1, 2).Value = "Total in Group"
         Cells(1, 3).Value = "English Entered"
         Cells(1, 4).Value = "English Passed"
         R = 1
      Else
         R = SecStat.UsedRange.Rows.Count
      End If
    On Error GoTo 0
 
 
    For Each Wks In Worksheets
      If Wks.Name <> SecStat.Name And Wks.Name <> "Data" And Wks.Name <> "Original" Then
         SecStat.Range("A1").Offset(R, 0) = Wks.Name
         SecStat.Range("A1").Offset(R, 1) = Wks.Range("D34")
         SecStat.Range("A1").Offset(R, 2) = Wks.Range("I75")
         SecStat.Range("A1").Offset(R, 3) = Wks.Range("I77")
         R = R + 1
      End If
    Next Wks
 
End Sub

Thank you for that, yes its sort of right but how do i get the data from the muliple sheets that have yet to be created?

In the first sheet you can list multiple groups and create multiple sheets using the macro (Data sheet) and copies and renames the sheets from original sheet (Original). Then how do i get data from the many sheets into the new one created (section statistics)?


Thanks for your help so far.

Matt

 

[Comfy]

It does this.

The macro will loop through all sheets with in the workbook.
It will ignore the "Data" and "Original" Sheets.

It will then copy the necessary info, you will need to change the cell references etc as what I posted was just a guide, to the newly created "Section Stats" sheet.

If the Section Stats sheet already exists this will not work as the macro needs more work.

I'm not sure I understand this:

how do i get the data from the muliple sheets that have yet to be created?

 

[mwillerton]

It does this.

The macro will loop through all sheets with in the workbook.
It will ignore the "Data" and "Original" Sheets.

It will then copy the necessary info, you will need to change the cell references etc as what I posted was just a guide, to the newly created "Section Stats" sheet.

If the Section Stats sheet already exists this will not work as the macro needs more work.

I'm not sure I understand this:

Ok, yes i see.

so the section stats sheet will not update if further data is entered?

 

[Comfy]

Ok, yes i see.

so the section stats sheet will not update if further data is entered?

Not at the moment.

For Each Wks In Worksheets
      If Wks.Name <> SecStat.Name And Wks.Name <> "Data" And Wks.Name <> "Original" Then
         SecStat.Range("A1").Offset(R, 0) = Wks.Name
         SecStat.Range("A1").Offset(R, 1).Formula = "='" & Wks.Name & "'!D34"
         SecStat.Range("A1").Offset(R, 2).Formula = "='" & Wks.Name & "'!I75"
         SecStat.Range("A1").Offset(R, 3).Formula = "='" & Wks.Name & "'!I77"
         R = R + 1
      End If
    Next Wks

This will paste links rather than values so if the group sheet is updated the Stats sheet will also.

Need alittle more for the final thing.

If the stat sheet already existed and it contained the group already would this need to be skipped?
If the stat sheet already existed and it didnt' contain the group already would this need to be added?

 

[mwillerton]

Not at the moment.

For Each Wks In Worksheets
      If Wks.Name <> SecStat.Name And Wks.Name <> "Data" And Wks.Name <> "Original" Then
         SecStat.Range("A1").Offset(R, 0) = Wks.Name
         SecStat.Range("A1").Offset(R, 1).Formula = "='" & Wks.Name & "'!D34"
         SecStat.Range("A1").Offset(R, 2).Formula = "='" & Wks.Name & "'!I75"
         SecStat.Range("A1").Offset(R, 3).Formula = "='" & Wks.Name & "'!I77"
         R = R + 1
      End If
    Next Wks

This will paste links rather than values so if the group sheet is updated the Stats sheet will also.

Need alittle more for the final thing.

If the stat sheet already existed and it contained the group already would this need to be skipped?
If the stat sheet already existed and it didnt' contain the group already would this need to be added?

If the sats sheet already existed and already contained the group it could be skipped, but it would still need to be checked as the group sheets will be updated with grades from time to time.

If the stat sheet already existed and a new group was added then the stat sheet would need to include this new group.

Thanks

 

[Comfy]

Ok, try this:

Sub Macro1a()

  Dim SecStat As Worksheet
  Dim R As Long
  Dim strName As String
  Dim Wks As Worksheet
  Dim Found As Range

   'Add the sheet if needed or use the existing one.
    On Error Resume Next
      Set SecStat = Worksheets("Section Statistics")
      If Err > 0 Then
         Set SecStat = Worksheets.add(After:=Worksheets(Worksheets.Count))
         ActiveSheet.Name = "Section Statistics"
         Cells(1, 2).Value = "Total in Group"
         Cells(1, 3).Value = "English Entered"
         Cells(1, 4).Value = "English Passed"
         R = 1
      Else
         R = SecStat.UsedRange.Rows.Count
      End If
    On Error GoTo 0
    
    For Each Wks In Worksheets
    With SecStat
        Set Found = .Columns(1).Find(What:=Wks.Name, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False)
    End With
    If Found Is Nothing Then
      If Wks.Name <> SecStat.Name And Wks.Name <> "Data" And Wks.Name <> "Original" Then
         SecStat.Range("A1").Offset(R, 0) = Wks.Name
         SecStat.Range("A1").Offset(R, 1).Formula = "='" & Wks.Name & "'!D34"
         SecStat.Range("A1").Offset(R, 2).Formula = "='" & Wks.Name & "'!I75"
         SecStat.Range("A1").Offset(R, 3).Formula = "='" & Wks.Name & "'!I77"
         R = R + 1
      End If
    End If
    Next Wks
    
End Sub