[英]VBA - copy / paste one cell from multiple workseets to master sheet
I have code which opens multiple files in a folder, prints the name of that file into column 1 (continuing down the column) of a masterfile, closes the current file, and moves onto the next one until the folder is empty. 我有打开一个文件夹中的多个文件的代码,将该文件的名称打印到masterfile的第1列(继续该列),关闭当前文件,然后移至下一个,直到文件夹为空。
There is information in cell J1(preferably written as 1,10) of all of the files that I want to copy while the file is open, paste into column 4 (continuing down the column, equal with the names of each file), and continue to close the current file and move on. 在文件打开时,我要复制的所有文件的单元格J1(最好写为1,10)中都有信息,粘贴到第4列(继续此列,与每个文件的名称相等),然后继续关闭当前文件并继续。
I cannot figure out how to copy just one cell since a range requires information over multiple rows. 我无法弄清楚如何仅复制一个单元格,因为范围需要多行信息。 Here is my working code for looping through files and just printing their name. 这是我的工作代码,用于遍历文件并仅打印文件名。 Any ideas? 有任何想法吗? Thanks! 谢谢!
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
Incorporate this, renaming "MySheet": 合并此名称,重命名“ 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
This should do it: 应该这样做:
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.