确保该文件夹下的Excel文件只有这100多，建一新Excel，也存到该文件夹。仅打开该新Excel，同时按Alt+F11进入宏界面，点菜单的插入，模块，在右边窗口粘贴如下代码：
Sub
Find()
Application.ScreenUpdating
=
False
Dim
MyDir
As
String
Dim
i
As
Integer
i
=
2
MyDir
=
ThisWorkbook.Path
&
"\"
ChDrive
Left(MyDir,
1)
'find
all
the
excel
files
ChDir
MyDir
Match
=
Dir$("*.xls")
Do
If
Not
LCase(Match)
=
LCase(ThisWorkbook.Name)
Then
Workbooks.Open
Match,
0,
1
ThisWorkbook.ActiveSheet.Range("A"
&
i)
=
Match
ThisWorkbook.ActiveSheet.Range("B"
&
i)
=
ActiveWorkbook.Sheets("Sheet1").Range("A3")
ThisWorkbook.ActiveSheet.Range("C"
&
i)
=
ActiveWorkbook.Sheets("Sheet1").Range("D5")
ActiveWorkbook.Close
0
i
=
i
+
1
End
If
Match
=
Dir$
Loop
Until
Len(Match)
=
0
Application.ScreenUpdating
=
True
End
Sub
在此界面下直接按F5运行此宏，等一会，完成。
如果你A3、D5等不多几个单元格，继续复制粘贴
ThisWorkbook.ActiveSheet.Range("C"
&
i)
=
ActiveWorkbook.Sheets("Sheet1").Range("D5")
把粗体字修改。
如果很多且有规律，可以用一个循环解决。
本文如未解决您的问题请添加抖音号：51dongshi（抖音搜索懂视），直接咨询即可。
热心网友
回答时间：2小时前
