How to automatically copy data in multiple spreadsheet

[Corried]

In multiple spreadsheets, in ALL cells in "F2" in "workbook 1".
How can I copy ALL cells in "F2" values and paste it VERTICALLY or downward column into a new "workbook 2", "worksheet1" in cell "B2"

See example below

The above worksheets is in "workbook1". All worksheets have data in "F2"
Then
Data is copied and paste into "workbook2" In "sheet1", vertically.

 

[davesexcel]

Assume both workbooks are opened.

Change workbook names as required.

Sub GetData()
    Dim wb As Workbook, bk As Workbook
    Dim sh As Worksheet, ws As Worksheet
    Dim LstRw As Long, f2 As String
    Set wb = Workbooks("wb2.xlsm")
    Set bk = Workbooks("wb1.xlsx")

    Set ws = wb.Sheets(1)

    For Each sh In bk.Sheets
        f2 = sh.Range("F2").Value

        With ws
            LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            .Range("A" & LstRw).Value = sh.Name
            .Range("B" & LstRw).Value = f2
        End With
    Next sh

End Sub

 

[Corried]

I seems like I can't get around this, It looks like I am stuck.
I have followed your tuition. Please set me straight:
Now "workbook2" really name is : "HEATMAP"
and
"workbook1" really name is : "Countries Worksheet PMI"

See below



Sub GetData()
Dim wb As Workbook, bk As Workbook
Dim sh As Worksheet, ws As Worksheet
Dim LstRw As Long, f2 As String
Set wb = Workbooks("HEATMAP .xlsm")
Set bk = Workbooks("Countries Worksheet PMI.xlsx")

Set ws = wb.Sheets(1)

For Each sh In bk.Sheets
f2 = sh.Range("F2").Value

With ws
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LstRw).Value = sh.Name
.Range("B" & LstRw).Value = f2
End With
Next sh

End Sub

 

[davesexcel]

Hi,
Check the file extension
.xlsx or .xlsm