求助！利用VBA在指定文件夹中打开全部Excel文件并复制指定单元格内容

Question

大家好：
我是一个VBA初学者，希望得到高手指导，下面叙述一下我的问题：
1、需要将原始测量数据中指定单元格内的数据提取出来，放入分析模板指定单元格内；（原始数据为CSV文件）
2、由于原始数据特别多（40个文件左右），模板也同样有40多个sheet，每个Sheet需要一一对应原始数据每个文件；
下面是我初步编写的语句，只能实现对一个数据进行提取，而且还存在一些问题：
Sub 打开1()
Dim myPath$, myFile$, AK As Workbook
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动
myPath = "C:\VBA\data\" '把文件路径定义给变量
myFile = Dir(myPath & "*.csv") '依次找寻指定路径中的*.xls文件
Do While myFile <> "" '当指定路径中有文件时进行循环
If myFile <> ThisWorkbook.Name Then
Set AK = Workbooks.Open(myPath & myFile) '打开符合要求的文件
End If
myFile = Dir '找寻下一个*.xls文件
Loop
Application.ScreenUpdating = True '冻结屏幕,此类语句一般成对使用
Range("E104:E175").Select
ActiveWindow.SmallScroll Down:=-72
Range("E104:E175,M104:M175").Select
Range("M104").Activate
Selection.Copy
Windows("模板.xlsm").Activate 选择模板
Sheets("1").Select
Range("O22").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim wb As Object
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then wb.Close True
Next
End Sub

问题点：1、怎样将多个原始文件按先后顺序打开并提取数据进入模板中每个Sheet？（一个原始文件对应一个sheet，sheet可以提前做出）
2、原始文件打开后，如何只关闭原始数据（我的命令里面，是除处理模板外的所有Excel全部关闭，这是不对的）
以上，请高手请教。
求指教，感激不尽

Answer 1

原来的程序里查找文件的办法看不明白，改用另一种方法，复制粘贴时的多余操作太多，进行了简化，改好的如下：
Sub 打开1()
Dim myPath$, AK As Workbook, OAK As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set OAK = ActiveWorkbook
myPath = "C:\VBA\data" '把文件路径定义给变量
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动
Set FD = fso.GetFolder(myPath)
I = 1
For Each F In FD.Files
If F.Type = "Microsoft Office Excel 逗号分隔值文件" Then
Set AK = Workbooks.Open(F.Path, , True) '打开符合要求的文件
AK.ActiveSheet.Range("E104:E175").Copy OAK.Sheets(I).Range("O22")
AK.ActiveSheet.Range("M104:M175").Copy OAK.Sheets(I).Range("P22")
AK.Close False
I = I + 1
Else
End If
Next
Application.ScreenUpdating = True '冻结屏幕,此类语句一般成对使用
End Sub追问

谢谢您的回复，
语句中：AK.ActiveSheet.Range("E104:E175").Copy OAK.Sheets(I).Range("O22")
AK.ActiveSheet.Range("M104:M175").Copy OAK.Sheets(I).Range("P22")
运行时出错！我想要的是，将指定文件夹中的原始数据（大约40左右），按顺序复制其中指定单元格数据，粘贴到模板中sheet（约40个sheet，数据按顺序粘贴进sheet中）
而您给的复制和粘贴，没有模板名称，这样运行可以吗？
PS：模板名称是“模板”

追答

OAK.Sheets(I)中的I是Sheet的序号，如果你的文件数量大于sheet 的数量，就会出错。我不知道你是一开始就出错还是运行到快结束才出错，要不然就是你的Sheet数量本来就不够。

追问

你好，sheet数量正好40，而我为了试验语句OK否，就只用了4个原始数据。所以sheet数量肯定够的！
运行一开始就报下限错误，导致失败！
我的问题是：你的语句里怎么没有模板名称字样啊？这样数据粘贴到哪里怎么知道啊？
补充：原始数据和模板不是一个文件。

Answer 2

太复杂，只能给你个建议：
顺序读取sheet表
每读取1个sheet表，在路径下查找对应的文件打开
读取文件，把原始数据拷贝到sheet表
关闭打开的文件（AK.Close set AK = Nothing)
读取下一个sheet表追问

您好，感谢回复!
由于原始数据文件名称是随机变化的，所以您的方法没有办法查找对应的文件。

追答

新建Excel表
顺序读取原始数据文件名
每读取1个文件，打开
在excel中添加工作表，把表名称定义为文件名
把原始数据拷贝到新添加的工作表
关闭打开的文件（AK.Close set AK = Nothing)
读取下一个文件名
保存Excel表并关闭

追问

怎么样顺序读取原始数据？
可以写成详细的VAB语句并标注说明，谢谢！

追答

Sub 打开1()
Dim myPath$, myFile$, AK As Workbook
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动
myPath = "C:\VBA\data\" '把文件路径定义给变量
myFile = Dir(myPath & "*.csv") '依次找寻指定路径中的*.csv文件
Do While myFile "" '当指定路径中有文件时进行循环
Set AK = Workbooks.Open(myPath & myFile) '打开文件
Application.ScreenUpdating = True '冻结屏幕,此类语句一般成对使用
With AK.Worksheets '操作ak数据表
Range("E104:E175").Select
ActiveWindow.SmallScroll Down:=-72
Range("E104:E175,M104:M175").Select
Range("M104").Activate
Selection.Copy
End With '结束操作
Application.DisplayAlerts = False '关闭警告信息显示
AK.Close '关闭AK表
Set AK = Nothing '清空内存中的AK表（提高计算机运行速度）
i = 1 '定义变量i的初始值为1
Windows("模板.xlsm").Activate '选择模板
Sheets("Sheet" & i & "").Select '选择工作表Sheet"i"，即Sheet1
Range("O22").Select
Selection.PasteSpecial Paste '粘贴到O22单元格
i = i + 1 '变量i的值加1，这样下一个Loop循环选择的工作表Sheet"i"就变成了Sheet2
myFile = Dir '找寻下一个*.csv文件
Loop
End Sub

追问

高手，太感谢您的帮助了！不过我使用了您的语句，解决一些问题但仍有问题存在：
1、由于原始数据中，需要提取不相邻的两行数据（E104:E175和M104:M175），使用我录制语句则可以正确放入模板O22：O93和P22：P93，但使用您语句时，则变成E到M共9行全部复制过去了！
2、我需要将原始文件夹（C:\VBA\data\）第一个CSV文件进入sheet 1模板中，第二个文件进入sheet 2，依次类推，怎样实现啊？万分感谢！

Answer 3

下面的方法可以不显示打开文件的过程，只是在内存中进行访问，速度比直接打开VBA脱离Excel就无法运行。不知道你是在什么情况下取单元格数据？ 如果是在追问

如果可以不打开Excel，就可以取单元格数据，就更理想了！
感谢您的回复！下面再补充说明：
1、需要在指定的文件夹中打开Excel文件（既Raw data），复制指定单元格内的数据，粘贴到模板指定位置；
2、由于原始数据数量较多（大约40个），需要按时间顺序一一打开，并一一重复1里面的操作；
说明：Raw data 有40个（每次数量不定，最多40），模板可以制作40个sheet与其对应。