求助：如何将文件夹下多个excel表相同位置的数据复制到另一张表中

taoyanghao · 发表于 2016-2-27 15:54

急急急！！！求高手相助，不胜感激！！！！！！

1578278106 · 发表于 2016-2-27 17:42

Sub 合并()
Dim myPath$, myFile$, AK As Workbook, aRow%, n As Integer
Application.ScreenUpdating = False
Sheets(1).Range("c2:e10000").ClearContents
myPath = ThisWorkbook.Path & "\表格"
myFile = Dir(myPath & "*.xls")
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
Set AK = Workbooks.Open(myPath & myFile)
aRow = AK.Sheets("主材清单").Range("f65536").End(xlUp).Row
AK.Sheets("主材清单").Range("f4:f" & aRow).Copy ThisWorkbook.Sheets(1).Range("c2").Offset(0, n)
Workbooks(myFile).Close False
End If
n = n + 1
myFile = Dir
Loop
Application.ScreenUpdating = True
MsgBox "合并完成，请查看！", 64, "提示"
End Sub

复制代码

1578278106 · 发表于 2016-2-27 17:54

Sub 合并()
Dim myPath$, myFile$, AK As Workbook, aRow%, n As Integer
Application.ScreenUpdating = False
Sheets(1).Range("c:e").ClearContents
myPath = ThisWorkbook.Path & "\表格"
myFile = Dir(myPath & "*.xls")
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
Set AK = Workbooks.Open(myPath & myFile)
aRow = AK.Sheets("主材清单").Range("f65536").End(xlUp).Row
AK.Sheets("主材清单").Range("f4:f" & aRow).Copy ThisWorkbook.Sheets(1).Range("c2").Offset(0, n)
ThisWorkbook.Sheets(1).Range("c2").Offset(-1, n) = VBA.Left(myFile, VBA.InStr(myFile, ".") - 1)
Workbooks(myFile).Close False
End If
n = n + 1
myFile = Dir
Loop
Application.ScreenUpdating = True
MsgBox "合并完成，请查看！", 64, "提示"
End Sub

复制代码

'加了一句

1578278106 · 发表于 2016-2-27 18:05

请看附件，附件格式为2016版。

模板.rar (771.06 KB, 下载次数: 324)

taoyanghao · 发表于 2016-3-2 07:18

新手，能不能具体说明一下每段程序的意思吗？？？

		自动登录	找回密码
密码			免费注册