VBA-將多個單元中的一個單元格復制/粘貼到主表

Question

我有打開一個文件夾中的多個文件的代碼，將該文件的名稱打印到masterfile的第1列（繼續該列），關閉當前文件，然后移至下一個，直到文件夾為空。

在文件打開時，我要復制的所有文件的單元格J1（最好寫為1,10）中都有信息，粘貼到第4列（繼續此列，與每個文件的名稱相等），然后繼續關閉當前文件並繼續。

我無法弄清楚如何僅復制一個單元格，因為范圍需要多行信息。 這是我的工作代碼，用於遍歷文件並僅打印文件名。 有任何想法嗎？ 謝謝！

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

合並此名稱，重命名“ 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

應該這樣做：

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