从多个文件复制单元格J1并粘贴到主文件列

我目前有这个代码，它会从一个文件夹中取出文件，打开每个文件，将其名称打印到我的主文件的第一列中，关闭它，并循环遍历整个文件夹。

I currently have this code which will take files from a folder, open each one, print its name into the first column of my "Master file" close it and loop through the entire folder that way.

在打开的每个文件中，单元格J1中都有我要复制并粘贴到主文件第3列的信息。代码工作，但只会将所需的信息从J1粘贴到C2中，以便信息不断被写入。我需要增加列表，所以J1的信息被打印到与文件名称相同的行。

In each file that is opened, there is information in cell J1 that I would like to copy and paste into column 3 of my "master file". The code works but will only paste the desired info from J1 into C2 over and over so the information keeps being written over. I need to increment down the list so the info from J1 is printed into the same row as the name of the file.

任何想法？

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

    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" And LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
        Else
            'print file name
            Sht.Cells(i + 1, 1) = objFile.Name
            i = i + 1
            Workbooks.Open fileName:=MyFolder & objFile.Name
        End If
        'Get TDS name of open file
        Dim NewWorkbook As Workbook
        Set NewWorkbook = Workbooks.Open(fileName:=MyFolder & objFile.Name)

        Range("J1").Select
        Selection.Copy
        Windows("masterfile.xlsm").Activate
        '
        '
        ' BELOW COMMENT NEEDS TO BE CHANGED TO INCREMENTING VALUES
        Range("D2").Select
        ActiveSheet.Paste
        NewWorkbook.Close
    Next objFile


End Sub