从多个工作簿中检索不连续的单元格并粘贴到主工作簿中

时间:2019-05-07 03:19:27

标签: excel vba

请帮助。 我在不同的文件夹中有四个工作簿。我想检索单元格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

0 个答案:

没有答案