VBA – 从多个工作区复制/粘贴一个单元格到主表单

我有打开文件夹中的多个文件的代码，将该文件的名称打印到主文件的第1列（继续向下列），closures当前文件，并移动到下一个文件夹，直到文件夹为空。

单元格J1中的信息（最好写为1,10）是我打算在文件打开时复制的所有文件的信息，粘贴到第4列（继续向下，等于每个文件的名称），以及继续closures当前文件并继续。

我不知道如何复制一个单元格，因为范围需要多行信息。 这是我的工作代码循环浏览文件，只是打印他们的名字。 有任何想法吗？ 谢谢！

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