提取文件夹中所有不同名称工作簿中相同名称工作表的固定位置内容并汇总到一个新的EXCEL工作簿中。
有几千个工作簿,每个工作簿名称都不一样。每个工作簿中含有多个工作表,其中的一个工作表(名称为TEST-RESULT)的第29行的B到M列数据(即B29:M29)是我需要的...
有几千个工作簿,每个工作簿名称都不一样。
每个工作簿中含有多个工作表,其中的一个工作表(名称为TEST-RESULT)的第29行的B到M列数据(即B29:M29)是我需要的。
结果显示为:每一行 = 工作簿的名称(放在第一列) + TEST-RESULT的B29:M29内容
所有结果在一个新的excel中。
需要一个VBA程序实现。哪位能帮忙写一下呢?感激不尽!我刚接触VBA,实在搞不定啊!可是任务多时间紧。拜托了! 展开
每个工作簿中含有多个工作表,其中的一个工作表(名称为TEST-RESULT)的第29行的B到M列数据(即B29:M29)是我需要的。
结果显示为:每一行 = 工作簿的名称(放在第一列) + TEST-RESULT的B29:M29内容
所有结果在一个新的excel中。
需要一个VBA程序实现。哪位能帮忙写一下呢?感激不尽!我刚接触VBA,实在搞不定啊!可是任务多时间紧。拜托了! 展开
1个回答
展开全部
可采用如下代码。该文件尽量不要放在目标文件夹中。运行时,只运行该workbook,其余关闭。
其中的扩展名(xls还是xlsx需要你确认一下,可更改)
Sub Data_Col()
Dim my_Path As String
Application.FileDialog(msoFileDialogFolderPicker).Show
my_Path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Dim my_Doc As String
my_Doc = Dir(my_Path & "\" & "*.xlsx") '手动更改扩展名
Dim j As Single
j = 1
Do While Len(my_Doc) <> 0
Workbooks.Open (my_Path & "\" & my_Doc)
ThisWorkbook.Worksheets(1).Cells(j,1)=my_doc
Dim i As Single
For i = 2 To 12
ThisWorkbook.Worksheets(1).Cells(j, i) = Workbooks(2).Worksheets("TEST -RESULT").Cells(29, i)
Next
Workbooks(2).Close
my_Doc = Dir
j = j + 1
Loop
End Sub
其中的扩展名(xls还是xlsx需要你确认一下,可更改)
Sub Data_Col()
Dim my_Path As String
Application.FileDialog(msoFileDialogFolderPicker).Show
my_Path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Dim my_Doc As String
my_Doc = Dir(my_Path & "\" & "*.xlsx") '手动更改扩展名
Dim j As Single
j = 1
Do While Len(my_Doc) <> 0
Workbooks.Open (my_Path & "\" & my_Doc)
ThisWorkbook.Worksheets(1).Cells(j,1)=my_doc
Dim i As Single
For i = 2 To 12
ThisWorkbook.Worksheets(1).Cells(j, i) = Workbooks(2).Worksheets("TEST -RESULT").Cells(29, i)
Next
Workbooks(2).Close
my_Doc = Dir
j = j + 1
Loop
End Sub
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询