How to loop through each worksheet and copy value to paste in new worksheet

[dahveedoff]

Hi Guys,

Newbie to VBA!!
I need to loop through worksheets in a workbook and copy every first cell value(A1) and then paste into a new worksheet.

I have tried various loops. some have copied first value for the first sheet and then pasted in the new sheet. while others have been not so good.

This is the code I have so far and this does not work at all.

Sub Check()
Dim ws As Worksheet
Dim lr As Long
Dim treg As Worksheet
Dim wok As Workbook
Dim i As Long
Dim j As Long
Dim n As Integer


Sheets("Dashboard").Visible = xlSheetVeryHidden
Sheets("RAW DATA").Visible = xlSheetVeryHidden
Sheets("Master").Visible = xlSheetVeryHidden
Set wok = ActiveWorkbook
Set treg = wok.Worksheets.Add(After:=wok.Worksheets(wok.Worksheets.Count))
treg.Name = "Summary"
For Each ws In wok.Worksheets
    If ws.Name <> "Summary" Then
        ws.Activate
     End If
     n = ActiveWorkbook.Worksheets.Count
        For i = 1 To n
            Cells(2, 1).Copy
            Sheets("Summary").Activate
            Sheets("Summary").Cells(i, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Next i
Next ws
        
Sheets("Dashboard").Visible = True
Sheets("Master").Visible = True
Sheets("Summary").Visible = True
End Sub

Please help out

 

[JackDanIce]

Welcome to the board. Try:

Sub Check()

Dim ws As Worksheet, wSummary As Worksheet
Dim i As Long:          i = 1

Application.ScreenUpdating = False

With ActiveWorkbook
    Set wSummary = .Worksheets.Add(after:=.Sheets(.Worksheets.Count)).Name = "Summary"
    For Each ws In .Worksheets
        Select Case ws.Name
            Case "Dashboard", "Master", wSummary.Name
                ' Do nothing
            Case Else
                wSummary.Range("A" & i) = ws.Range("A1")
                i = i + 1
        End Select
    Next ws
    wSummary.Select
End With

Application.ScreenUpdating = True

Set wSummary = Nothing: Set ws = Nothing

End Sub