Extracting data from multiple sheets

[kmc]

I am looking to pull data from the following cells B1,B7,B8,B10, & B17 in a WB that about 80 sheets and post it to a blank sheet. Destination can follow the same cells or post in A1, A2, A3 etc.

Thank you

 

[andiemac]

I wasn't completely sure how you wanted the data to be displayed in the destination, but this should give you a good start.

Sub Multi_Sheet_Data_Collect()
Dim iSheetCount, iSheet
Dim n As Long
 
iSheetCount = ActiveWorkbook.Worksheets.Count
n = 1
For iSheet = 1 To iSheetCount
Worksheets(iSheet).Activate

If ActiveSheet.Name = "Dest Page" Then
Else

Range("B1,B7,B8,B10,B17").Select
Selection.Copy
Worksheets("Dest Page").Activate
Range("A" & n).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=True
n = n + 1
End If
Next iSheet
End Sub

 

[Yahya]

Try this

Sub Test()
Dim ws As Worksheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Total"
For Each ws In Sheets
    ws.Range("B1,B7,B8,B10,B17").Copy Sheets("Total").Cells(1, Sheets("Total").Cells(1, Columns.Count).End(xlToLeft).Column + 1)
Next ws
End Sub

 

[kmc]

andiemac - got a run time error at the following:
Worksheets("Dest Page").Activate

Yahya - worked well until it hit a page with merged cells then stopped. Otherwise nice.

thank you both.

 

[jbeaucaire]

My slightly diff approach:

Option Explicit

Sub CollectData()
Dim ws As Worksheet, NR As Long

If Not Evaluate("ISREF(Summary!A1)") Then
    Sheets.Add(Before:=Sheets(Sheets.Count)).Name = "Summary"
Else
    Sheets("Summary").Cells.Clear
End If

NR = 1

With Sheets("Summary")
    For Each ws In Worksheets
        If ws.Name <> "Summary" Then
            .Range("A" & NR).Value = ws.Range("B1").Value
            .Range("B" & NR).Value = ws.Range("B7").Value
            .Range("C" & NR).Value = ws.Range("B8").Value
            .Range("D" & NR).Value = ws.Range("B10").Value
            .Range("e" & NR).Value = ws.Range("B17").Value
            NR = NR + 1
        End If
    Next ws
End With

End Sub

The .Value method shouldn't fail when it hits merged cells.

 

[kmc]

With a "slightly better" result. Thanks for reading my mind better than I did!