Excel VBA 读取其他的Excel文件内的内容

'初级版每次只能对单一文件进行操作； 

'进阶版可对多个文件进行操作（文件夹内及其子文件夹内的文件都可操作），方便快捷；

'进阶版中  Private Function fcnGetFileList(sFolderPath As String) As Variant

'End Function

'方法的实现可复制 本人创作的《VBA 实现把格式相同的多个word网格数据批量转到excel文件中》中 fcnGetFileList 方法到进阶版中，替换即可使用

不会使用VBA操作的，可查看本人创作的 《如何打开 Excel VBA 及 我的第一个代码》，打开代码编辑器，  复制代码到编辑器内就可以正常使用了

'注：初级版   和  进阶版 代码只需要复制其中一个就可以了

'创建一个Excel 文件名为：（ 汇总表.xlsm ） 的文件，代码粘贴在编辑器内

'---------------------------------------------------初级版-----------------------------------------------

'-----------清除内容和格式---------
Sub Clearbody()
 a = Cells.SpecialCells(xlCellTypeLastCell).Row    '-----最后一行----
 Range("a3:k" & a +1 ).ClearContents
 Range("a3:k" & a +1).ClearFormats
End Sub

Sub ExecuteExcel()

    Clearbody

    
    '取消屏幕刷新
    Application.ScreenUpdating = False
    '禁止显示提示和警告消息；当出现需要用户应答的消息时，Excel将选择默认应答
    Application.DisplayAlerts = False
        

    Dim wb As Workbook    

    Range("A1").Select

     '自定义文件名和所在目录
    Set wb = Workbooks.Open("D:\test.xlsl")
    a = Cells.SpecialCells(xlCellTypeLastCell).Row    '-----最后一行----     

   '自定义复制的区间    目前是 A1 到 K列 
   Range("A1:K" & a).Select
        
   Selection.Copy
   Windows("汇总表.xlsm").Activate
       
   a = Cells.SpecialCells(xlCellTypeLastCell).Row    '-----最后一行----
        
  Range("A" & a + 1).Select
  ActiveSheet.Paste
  wb.Close
  Set wb = Nothing
    
    
    '----------------------删除空白行----------------------
    a = Cells.SpecialCells(xlCellTypeLastCell).Row    '-----最后一行----
    For i = a To 3 Step -1
        If (Cells(i, 1) = "") Then
            Rows(i).Delete
        End If
    Next
    '----------------------删除空白行----------------------
    

    '设置行高
    Rows("3:" & a).RowHeight = 52
    Range("A3").Select
    
    '开启屏幕刷新
    Application.ScreenUpdating = True
    '开启显示提示和警告消息
    Application.DisplayAlerts = False
    
End Sub

'---------------------------------------------------进阶版-----------------------------------------------

'-----------清除内容和格式-------------------------
Sub Clearbody()
 a = Cells.SpecialCells(xlCellTypeLastCell).Row    '-----最后一行----
 Range("a3:k" & a +1 ).ClearContents
 Range("a3:k" & a +1).ClearFormats
End Sub

Sub ExecuteExcel()

    Clearbody

    Dim strFolder As String
    Dim varFileList As Variant
    Dim FSO As Object, myFile As Object
    
    '显示打开文件夹对话框
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub '未选择文件夹
        strFolder = .SelectedItems(1)
    End With
    
    '获取文件夹中的所有文件列表
    varFileList = fcnGetFileList(strFolder)
    If Not IsArray(varFileList) Then
        MsgBox "未找到文件", vbInformation
        Exit Sub
    End If
    
    '取消屏幕刷新
    Application.ScreenUpdating = False
    '禁止显示提示和警告消息；当出现需要用户应答的消息时，Excel将选择默认应答
    Application.DisplayAlerts = False
        

    Dim wb As Workbook
    
    For x = 0 To UBound(varFileList)

        Range("F6").Select
        Set wb = Workbooks.Open(varFileList(x))

        
        a = Cells.SpecialCells(xlCellTypeLastCell).Row    '-----最后一行----
        

        '自定义复制的区间    目前是 A1 到 K列 
        Range("A3:K" & a).Select
        
        Selection.Copy
        Windows("汇总表.xlsm").Activate
        
        a = Cells.SpecialCells(xlCellTypeLastCell).Row    '-----最后一行----
        
        Range("A" & a + 1).Select
        ActiveSheet.Paste
        wb.Close
        
    Next x
    
    Set wb = Nothing
    
    
    '----------------------删除空白行----------------------
    a = Cells.SpecialCells(xlCellTypeLastCell).Row    '-----最后一行----
    For i = a To 3 Step -1
        If (Cells(i, 1) = "") Then
            Rows(i).Delete
        End If
    Next
    '----------------------删除空白行----------------------
    

    '设置行高
    Rows("3:" & a).RowHeight = 52
    Range("A3").Select
    
    '开启屏幕刷新
    Application.ScreenUpdating = True
    '开启显示提示和警告消息
    Application.DisplayAlerts = False
    
End Sub

Private Function fcnGetFileList(sFolderPath As String) As Variant
' 将文件列表放到数组

End Function