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

Question

我目前有这段代码可以从一个文件夹中获取文件，打开每个文件，将其名称打印到我的 "Master file" 的第一列中，然后关闭它并以这种方式循环遍历整个文件夹。

在打开的每个文件中，单元格 J1 中都有我想复制并粘贴到 "master file" 的第 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

我对你的代码做了一些修改，它显示了你需要的结果。
请注意，如果您的文件夹有其他文件扩展名，您的宏可能会损坏。
您可以使用以下代码提高此宏的性能：
Application.ScreenUpdating = 假

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 2

如果工作表名称在文件中是一致的，即 "Sheet1"，您可以在不打开文件的情况下执行此操作：

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

Answer 3

这是有效的解决方案：

'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

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

Copy cell J1 from multiple files and paste into column of masterfile

excel

vba

copy

paste