Excel使用宏VBA在新建的工作簿中汇总罗列(复制粘贴)同一文件夹下不同工作簿中某一工作表的同一区域数据。

一、按住 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，快捷唤出模块。