一、按住 ALT + F11 键打开 Microsoft Visual Basic应用程序 窗口。
二、点击 插页 > 模块,然后将以下代码粘贴到 模块 窗口。
Sub Request()
Dim Mypath, MyName
Filename1 = ThisWorkbook.Sheets("工作表名称").Cells(1, 5).Value
Mypath = ThisWorkbook.Path & "\" ' 指定路径。
MyName = Dir(Mypath, vbDirectory) '文件名称
Application.ScreenUpdating = False
Do While MyName <> "" '遍历所有上报的excel
If MyName <> "." And MyName <> ".." And (MyName Like "*工作簿名称相同关键字*.xls" Or MyName Like "*工作簿名称相同关键字*.xlsx") Then
'ThisWorkbook.Sheets("工作表名称").Select
For i = 2 To 300
If ThisWorkbook.Sheets("工作表名称").Cells(2, i) <> "" And MyName Like "*" & ThisWorkbook.Sheets("工作表名称").Cells(2, i) & "*" Then
Debug.Print Cells(2, i)
Set openfile = Workbooks.Open(Mypath + MyName) '打开单个excel
'第一次copy
Workbooks(MyName).Activate
Range("E" & 4, "H" & 7).Copy
Workbooks(Filename1).Activate
Range(Cells(4, i + 1), Cells(7, i + 4)).Select
Selection.PasteSpecial Paste:=xlPasteValues
'第二次copy
Workbooks(MyName).Activate
Range("E" & 10, "H" & 13).Copy
Workbooks(Filename1).Activate
Range(Cells(10, i + 1), Cells(13, i + 4)).Select
Selection.PasteSpecial Paste:=xlPasteValues
'第三次copy
Workbooks(MyName).Activate
Range("D" & 9, "D" & 9).Copy
Workbooks(Filename1).Activate
Range(Cells(9, i), Cells(9, i)).Select
Selection.PasteSpecial Paste:=xlPasteValues
'Debug.Print Cells(2, i)
'循环后检查,是否还有excel打开状态
Set MyExcel = GetObject(, "Excel.Application")
For Each axls In MyExcel.Workbooks
If InStr(1, axls.Name, MyName, 1) Then
Workbooks(MyName).Close False
End If
Next
End If
Next
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
End Sub
三、按住 ALT + F8,快捷唤出模块。
瞅瞅瞅瞅,mark一手
真棒,感谢分享!