VBA 抽出文件夹下所有文件中指定单元格的内容

Sub output()
 Application.ScreenUpdating = False
 Dim Mydir As String
 Dim i As Integer
 i = 2
 Mydir = ThisWorkbook.Path & "\"
 ChDrive Left(Mydir, 1)
 ChDir Mydir
 '文件名
 Match = Dir$("*.xlsx")
 Do
 If Not LCase(Match) = LCase(ThisWorkbook.Name) Then
 Workbooks.Open Match, True
 '文件名放到A列
 ThisWorkbook.ActiveSheet.Range("A" & i) = Match
 'A4单元格的内容放到sheet1的B列
 ThisWorkbook.ActiveSheet.Range("B" & i) = ActiveWorkbook.Sheets("sheet1").Range("A4")
 'A4单元格的内容放到sheet1的C列
 ThisWorkbook.ActiveSheet.Range("C" & i) = ActiveWorkbook.Sheets("sheet1").Range("K4")
 ActiveWorkbook.Close 0
 i = i + 1
 End If
 Match = Dir$
 Loop Until Len(Match) = 0
 Application.ScreenUpdating = True
End Sub