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

 

[mwillerton]

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

That is brilliant, thank you so much. I bow to your superior knowledge.

Is there a way i can approve your assistance or give you some sort of star rating???

Thanks

Matt

 

[Comfy]

Nope, Don't think so.

Glad I could help