VBA - copy / paste one cell from multiple workseets to master sheet - excel

Question

I have code which opens multiple files in a folder, prints the name of that file into column 1 (continuing down the column) of a masterfile, closes the current file, and moves onto the next one until the folder is empty.
There is information in cell J1(preferably written as 1,10) of all of the files that I want to copy while the file is open, paste into column 4 (continuing down the column, equal with the names of each file), and continue to close the current file and move on.
I cannot figure out how to copy just one cell since a range requires information over multiple rows. Here is my working code for looping through files and just printing their name. Any ideas? Thanks!
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet
Dim i As Integer
Dim LastRow As Integer, erow As Integer
'Speed up process by not updating the screen
'Application.ScreenUpdating = False
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'print file name
Sht.Cells(i + 1, 1) = objFile.Name
i = i + 1
Workbooks.Open fileName:=MyFolder & objFile.Name
End If
'Macro recording of manual copy/paste but I want to apply on general scale
'Range("J1").Select
'Selection.Copy
'Windows("masterfile.xlsm").Activate
'Range("D2").Select
'ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=False
Next objFile
'Application.ScreenUpdating = True
End Sub

Answer 1

Incorporate this, renaming "MySheet":
Option Explicit
Sub CopyFromSheets()
Dim WB As Workbook
Dim ws As Worksheet
Dim i As Integer
Set WB = ActiveWorkbook
i = 1
With WB
For Each ws In .Worksheets
With ws
.Range("J1").Copy Workbooks("masterfile.xlsm").Sheets("MySheet").Cells(i, 10) 'Rename Mysheet
i = i + 1
End With
Next ws
End With
End Sub
This should do it:
Option Explicit
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
Dim LastRow As Integer, erow As Integer
Application.ScreenUpdating = False
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = Workbooks("masterfile.xlsm").Sheets("MySheet")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'print file name
Workbooks.Open Filename:=MyFolder & objFile.Name
Set WB = ActiveWorkbook
With WB
For Each ws In .Worksheets
Sht.Cells(i + 1, 1) = objFile.Name
With ws
.Range("J1").Copy Sht.Cells(i + 1, 4)
End With
i = i + 1
Next ws
.Close SaveChanges:=False
End With
End If
Next objFile
Application.ScreenUpdating = True
End Sub