Question

我有4个包含Excels文件的文件夹。我想从不同的工作簿中复制非连续的单元格（A1，B4，C6，D8）并将其粘贴到主工作簿中。 A1代表日期，B4代表姓名，C6代表年龄，D8代表地址。逐行显示。

我的代码显示在下面：

Sub LoopFolders()
'Declare variabes
Dim myFolder As String
Dim mySubFolder As String
Dim myFile As String
Dim collSubFolders As New Collection
Dim myItem As Variant 'excel will decide what kind of variable that is
Dim wbk As Workbook


Dim copyRange As Range, cel As Range, pasteRange As Range


'Set the parent folder
myFolder = "C:\Users\sunvi\Desktop\test\FEB 19\"
'retrieve my subfolder using the directory function
mySubFolder = Dir(myFolder & "*", vbDirectory)
'Make our macro run faster
Application.ScreenUpdating = False

'Run a loop
Do While mySubFolder <> ""
'Use Select case statement
Select Case mySubFolder
'one dot refer to current folder/two dots refer to the parent folder
Case ".", ".." 'it would do nothing if it is the curent folder or parent folder.

Case Else
'add a folder(subfolder) to our collection

collSubFolders.Add Item:=mySubFolder  'add a item to our subfolder collection
End Select

'retrieve Next subfolder using the directory function without givig any parameter to the Dir function
mySubFolder = Dir
Loop ' do while loop


'loop through each subfolders in my collection of subfolders


For Each myItem In collSubFolders

'loop through excel workbooks in subfolders
myFile = Dir(myFolder & myItem & "\*.xlsm*")

'within this loop nested a do while loop
Do While myFile <> ""
'Open a workbook
Set wbk = Workbooks.Open(Filename:=myFolder & myItem & "\" & myFile)
'Defining the lastrow before copying data
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Defining the lastcolumn before copying data
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column


'we use the set keyword to create a new object
Set copyRange = ActiveSheet.Range("I2,D46,D47,D48,D49")

Set pasteRange = ThisWorkbook.Sheets("FEB 18").Range("A1")


For Each cel In copyRange
cel.Copy
'erow defines the next blank row


'Once copy close workbook
wbk.Close SaveChanges:=False 'prevent data to chane from original workbook

'paste data in activeworksheet
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'offset(1,0) by one row
'ecolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column

ActiveSheet.Cells(erow, 1).Select

ActiveSheet.PasteSpecial xlPasteValues
'pasteRange.Cells(erow, 1).PasteSpecial xlPasteValues


'ActiveSheet.Paste


'ActiveSheet.Paste Destination:=Worksheets("FEB 18").Range(Cells(erow, 1), Cells(erow, 4))



Next '............................








ActiveWorkbook.Save

'remove the ant-like selection
Application.CutCopyMode = False
'get next file


myFile = Dir
Loop 'close do while


Next myItem 'close for loop
'Activate screenupdating
Application.ScreenUpdating = True


End Sub

Answer 1

这部分代码不起作用，仅显示I2单元格的数据，无法显示来自不同工作簿的所有非连续单元格数据

设置copyRange = ActiveSheet.Range（“ I2，D46，D47，D48，D49”）

设置pasteRange = ThisWorkbook.Sheets（“ masterWrkSheet”）。Range（“ A1”）

对于复制范围中的每个cel

cel.Copy

wbk.Close SaveChanges：= False

erow = ActiveSheet.Cells（Rows.Count，1）.End（xlUp）.Offset（1，0）.Row ActiveSheet.Cells（erow，1）.Select

ActiveSheet.PasteSpecial xlPasteValues

下一步

Answer 2