Macro to build list of multiple worksheets

[detweiler]

Did a lot of skulking around the inter webs and frankencoded the following to gather that should pull variables from specific cells on multiple worksheets within a workbook into a newly created worksheet in that same workbook. The macro runs and get the message box saying the data extraction is done, but the new worksheet is not gettin created.

Here's what I was able to put together. Your comments ad suggestions are appreciated.

Sub ExtractDataToSummary()

    Dim ws As Worksheet
    Dim infoSheet As Worksheet
    Dim infoRow As Long
    Dim data(1 To 3) As Variant
    Dim excludeSheets As Collection
    Dim sheetName As String

    ' don't know why, but this is the part that isn't working; gets skipped when stepping through the code

    ' here's where the new worksheet is supposed to get created after checking it's not there
    Set infoSheet = ThisWorkbook.Sheets("Info List")
    On Error GoTo 0
    If infoSheet Is Nothing Then
        Set infoSheet = ThisWorkbook.Sheets.Add
        infoSheet.Name = "Info List"
      End If

    ' begin to build the list of the pulled data
    infoSheet.Cells(1, 1).Value = "Worksheet Name"
    infoSheet.Cells(1, 2).Value = "B2"
    infoSheet.Cells(1, 3).Value = "B3"
    infoSheet.Cells(1, 4).Value = "B7"
    infoRow = 2

    'need to exclude support worksheets
    Set excludeSheets = New Collection
    excludeSheets.Add "thisWorksheet"
    excludeSheets.Add "thatWorksheet"

    ' go through each worksheet and collect data
    For Each ws In ThisWorkbook.Worksheets
        sheetName = ws.Name
        If Not IsInCollection(excludeSheets, sheetName) Then
            data(1) = ws.Range("B2").Value
            data(2) = ws.Range("B3").Value
            data(3) = ws.Range("B7").Value

            ' put the data on the list sheet
            infoSheet.Cells(summaryRow, 1).Value = sheetName
            infoSheet.Cells(summaryRow, 2).Value = data(1)
            infoSheet.Cells(summaryRow, 3).Value = data(2)
            infoSheet.Cells(summaryRow, 4).Value = data(3)
            infoRow = summaryRow + 1

        End If

    Next ws

    MsgBox "Data extraction complete!", vbInformation


End Sub

Function IsInCollection(coll As Collection, key As Variant) As Boolean
    Dim item As Variant
    On Error Resume Next
    item = coll(key)
    IsInCollection = (Err.Number = 0)
    Err.Clear

End Function

 

[RoryA]

That code can't work as you never assign a value to summaryRow. Even if you did, you'd just overwrite the same cells as you don't increment summaryRow. Also, to be clear, that code is processing the workbook with the code in, which may or may not be the active workbook.

 

[mumps]

Try this macro. Change the sheet names (in red) to suit your needs.

Sub ExtractDataToSummary()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, infoSheet As Worksheet
    If Not Evaluate("isref('Info List'!A1)") Then
        Set infoSheet = Sheets.Add(After:=Sheets(Sheets.Count))
        ActiveSheet.Name = "Info List"
        Range("A1").Resize(, 4).Value = Array("Worksheet Name", "B2", "B3", "B7")
    End If
    For Each ws In Sheets
        If ws.Name <> "thisWorksheet" And ws.Name <> "thatWorksheet" And ws.Name <> "Info List" Then
            With infoSheet
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4).Value = Array(ws.Name, ws.Range("B2").Value, ws.Range("B3").Value, ws.Range("B7").Value)
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
    MsgBox "Data extraction complete!", vbInformation
End Sub

 

[detweiler]

Try this macro. Change the sheet names (in red) to suit your needs.

Sub ExtractDataToSummary()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, infoSheet As Worksheet
    If Not Evaluate("isref('Info List'!A1)") Then
        Set infoSheet = Sheets.Add(After:=Sheets(Sheets.Count))
        ActiveSheet.Name = "Info List"
        Range("A1").Resize(, 4).Value = Array("Worksheet Name", "B2", "B3", "B7")
    End If
    For Each ws In Sheets
        If ws.Name <> "thisWorksheet" And ws.Name <> "thatWorksheet" And ws.Name <> "Info List" Then
            With infoSheet
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4).Value = Array(ws.Name, ws.Range("B2").Value, ws.Range("B3").Value, ws.Range("B7").Value)
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
    MsgBox "Data extraction complete!", vbInformation
End Sub

Much thanks. Way more efficient than the frankencode I pieced together and works as needed. Merely noting that for an unknown reason it puts the name of the excluded worksheets in row 2. I've stepped through it and cannot see where it's doing that at... just odd.

 

[mumps]

it puts the name of the excluded worksheets in row 2.

That is odd. Could you upload a copy of your file (de-sensitized if necessary) to a free site such as www.box.com or www.dropbox.com? Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. I wouldn't need all the data. Just 10 rows or so in each sheet.