Скопировать ячейку J1 из нескольких файлов и вставить в столбец мастер-файла

Question

В настоящее время у меня есть этот код, который будет извлекать файлы из папки, открывать каждый, печатать свое имя в первый столбец моего «основного файла», закрывать его и прокручивать вся папка.

В каждом открывшемся файле есть информация в ячейке J1, которую я хотел бы скопировать и вставить в столбец 3 моего «основного файла». Код работает, но будет только вставлять желаемую информацию из J1 в C2 снова и снова, чтобы информация продолжала записываться. Мне нужно увеличить список, чтобы информация из J1 была напечатана в той же строке, что и имя файла.

Любые идеи?

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 

Answer 1

Это решение, которое работает:

'print J1 values to Column 4 of masterfile 
     With WB 
      For Each ws In .Worksheets 
       StartSht.Cells(i + 1, 1) = objFile.Name 
       With ws 
        .Range("J1").Copy StartSht.Cells(i + 1, 4) 
       End With 
       i = i + 1 
      'move to next file 
      Next ws 
      'close, do not save any changes to the opened files 
      .Close SaveChanges:=False 


     End With 

Answer 2

я сделать некоторые изменения в свой код и он показывает результат, необходимый вам.
Обратите внимание, что ваш макрос может испортиться, если ваша папка получила другое расширение файлов.
Вы можете увеличить производительность этого макроса с помощью следующего кода:
Application.ScreenUpdating = False

Option Explicit 

Dim MyMasterWorkbook As Workbook 
Dim MyDataWorkbook As Workbook 
Dim MyMasterWorksheet As Worksheet 
Dim MyDataWorksheet As Worksheet 

Sub LoopThroughDirectory() 

Set MyMasterWorkbook = Workbooks(ActiveWorkbook.Name) 
Set MyMasterWorksheet = MyMasterWorkbook.ActiveSheet 

Dim objFSO As Object 
Dim objFolder As Object 
Dim objFile As Object 
Dim MyDataFolder As String 
Dim MyFilePointer As Byte 

MyDataFolder = "C:\Users\lengkgan\Desktop\Testing\" 
MyFilePointer = 1 

'create an instance of the FileSystemObject 
Set objFSO = CreateObject("Scripting.FileSystemObject") 

'get the data folder object 
Set objFolder = objFSO.GetFolder(MyDataFolder) 

'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 
     MyMasterWorksheet.Cells(MyFilePointer + 1, 1) = objFile.Name 
     MyFilePointer = MyFilePointer + 1 
     Workbooks.Open Filename:=MyDataFolder & objFile.Name 
    End If 

'Get TDS name of open file 
Set MyDataWorkbook = Workbooks.Open(Filename:=MyDataFolder & objFile.Name) 
Set MyDataWorksheet = MyDataWorkbook.ActiveSheet 

'Get the value of J1 
MyMasterWorksheet.Range("C" & MyFilePointer).Value = MyDataWorksheet.Range("J1").Value 

'close the workbook without saving it 
MyDataWorkbook.Close (False) 
Next objFile 
End Sub 

Answer 3

ЕСЛИ SheetName согласуется через файлы, т.е. «Лист1», вы можете сделать это без открытия файлов:

Sub LoopThroughDirectory() 
    Dim objFSO As Object, objFolder As Object, objFile As Object, MyFolder As String, Sht As Worksheet 
    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) 
    'loop through directory file and print names 
    For Each objFile In objFolder.Files 
     If Not LCase(Right(objFile.Name, 3)) <> "xls" And Not LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then 
      'print file name 
      Sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Formula = objFile.Name 
      Sht.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Formula = ExecuteExcel4Macro("'" & MyFolder & objFile.Name & "Sheet1'!R1C10") 'This reads from a closed file 
     End If 
    Next objFile 
End Sub