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

问题

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.

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.

Any ideas?

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

回答1:

I do some modification on your code and it shows the result that needed by you.
Please take note that your macro may spoil if your folder got other extension of files.
You may increase the performance of this macro by using the following code :
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

回答2:

IF the sheetname is consistent across the files ie "Sheet1", you can do this without opening the files:

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

回答3:

This is the solution that works:

'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

来源：https://stackoverflow.com/questions/30573398/copy-cell-j1-from-multiple-files-and-paste-into-column-of-masterfile