请帮助。 我在不同的文件夹中有四个工作簿。我想检索单元格A4(日期),B12(总名册),B13(劳动力),B14(总ABS)和C15(百分比ABS)并将其显示在主工作簿中
代码如下所示
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 ".", ".."
Case Else
'add a folder(subfolder) to our collection
collSubFolders.Add Item:=mySubFolder 'add a item to our subfolder collection
End Select
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 <> ""
Set wbk = Workbooks.Open(Filename:=myFolder & myItem & "\" & myFile)
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
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
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.PasteSpecial xlPasteValues
'pasteRange.Cells(erow, 1).PasteSpecial xlPasteValues
ActiveSheet.Paste
Next
ActiveWorkbook.Save
'remove the ant-like selection
Application.CutCopyMode = False
'get next file
myFile = Dir
Loop 'close do while
'close for loop
Next myItem
'Activate screenupdating
Application.ScreenUpdating = True
End Sub