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

兰明明

已于 2023-02-14 14:21:41 修改

阅读量1.8k

点赞数 2

分类专栏： VBA 文章标签： vba

于 2021-08-06 14:29:51 首次发布

本文链接：https://blog.csdn.net/baidu_37289241/article/details/119454301

版权

VBA 专栏收录该内容

4 篇文章 0 订阅

订阅专栏

这段代码用于禁用屏幕更新，然后在当前工作簿所在目录下查找所有.xlsx文件。对于每个找到的文件，如果它不是当前工作簿，就打开它，将文件名写入A列，将Sheet1的A4单元格内容分别写入B列和C列，然后关闭文件。最后恢复屏幕更新。

摘要由CSDN通过智能技术生成

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