[已解决]向及各位老师求教如何实现批量粘贴一文件夹下工作簿数据至另一文件夹下同名工作簿中

dxllxb · 发表于 2012-12-29 11:41

感谢hwc2ycy老师和疯子老师的帮助，进一步请教
2个文件夹，2012, 201301
希望通过vba实现打开2012下一工作簿（均为sheet1），运行宏，运行结果的数据，选择性粘贴（数据）至201301同名工作簿（2013工作表）中,请教如何实现
测试文件，及宏已上传

最佳答案

suye1010

2012-12-29 16:47

本帖最后由 suye1010 于 2012-12-29 16:49 编辑

GenerateFile.rar (148.66 KB, 下载次数: 8, 售价: 5 个金币)

2012-12-29 16:46 上传

点击文件名下载附件
这个方案你看看可行？

Sub GetData()
Dim Arr0, Arr(1 To 24, 1 To 6), MyFilePath As String, SingleFile As String, MyFiles() As String, Wb As Workbook, EApp As New Application, k As Integer
MyFilePath = ThisWorkbook.Path & Application.PathSeparator
SingleFile = Dir(MyFilePath & "20130101\*.*")
Do While SingleFile <> ""
k = k + 1
ReDim Preserve MyFiles(1 To k)
MyFiles(k) = SingleFile
SingleFile = Dir
Loop
Set EApp = New Application
For k = 1 To UBound(MyFiles)
Arr0 = GetDataFromClosedFile(MyFilePath & "2012" & MyFiles(k), "Sheet1", "$B$2:$E$25")
If Arr0(1, 1) = "File Not Found.FileFullName is consist of file path and name." Then
MsgBox MyFiles(k) & " Not found in folder 2012"
GoTo 100
Else
For i = 1 To 24
Arr(i, 1) = Arr0(i, 1)
Arr(i, 2) = Arr0(i, 2)
Arr(i, 3) = Arr0(i, 3)
Arr(i, 4) = IIf(Val(Arr0(i, 3)) > 10560, 10560, IIf(Val(Arr0(i, 3)) >= 2006, Arr0(i, 3), IIf(Val(Arr0(i, 3)) <> 0, 2006, "")))
Arr(i, 5) = IIf(Val(Arr0(i, 4)) = 5, "农民工", "")
Arr(i, 6) = IIf(Val(Arr0(i, 3)) > 10560, 10560, IIf(Val(Arr0(i, 3)) >= 2006, Arr0(i, 3), IIf(Val(Arr0(i, 3)) <> 0, 2006, "")))
Next i
End If
Set Wb = EApp.Workbooks.Open(MyFilePath & "20130101" & MyFiles(k))
With Wb
.Sheets("2013").Cells(4, 3).Resize(24, 6) = Arr
.Close True
End With
100:
Erase Arr0
Erase Arr
Next
EApp.Quit
MsgBox "All documents have been updated."
End Sub

复制代码

Public Function GetDataFromClosedFile(ByVal FileFullName As String, _
ByVal SheetName As String, _
ByVal Range_Ref As String) As Variant
Dim FilePath As String, FileName As String
Dim cell As Range, i As Integer, ReturnData, Arg As String
'判断文件是否存在
If Dir(FileFullName) = "" Then
ReDim ReturnData(1 To 1, 1 To 1)
ReturnData(1, 1) = "File Not Found.FileFullName is consist of file path and name."
GoTo Exit_Function
End If
ReDim ReturnData(1 To Range(Range_Ref).Rows.Count, 1 To Range(Range_Ref).Columns.Count)
FilePath = Left(FileFullName, InStrRev(FileFullName, Application.PathSeparator))
FileName = Mid(FileFullName, InStrRev(FileFullName, Application.PathSeparator) + 1)
For Each cell In Range(Range_Ref)
Arg = "'" & FilePath & "[" & FileName & "]" & SheetName & "'!" _
& cell.Address(, , xlR1C1)
ReturnData(cell.Row - Range(Range_Ref).Row + 1, cell.Column - Range(Range_Ref).Column + 1) = _
IIf(Application.ExecuteExcel4Macro(Arg) = 0, "", Application.ExecuteExcel4Macro(Arg))
Next cell
Exit_Function:
GetDataFromClosedFile = ReturnData
End Function

复制代码

suye1010 · 发表于 2012-12-29 16:47

本帖最后由 suye1010 于 2012-12-29 16:49 编辑

GenerateFile.rar (148.66 KB, 下载次数: 8, 售价: 5 个金币)

2012-12-29 16:46 上传

点击文件名下载附件
这个方案你看看可行？

Sub GetData()
Dim Arr0, Arr(1 To 24, 1 To 6), MyFilePath As String, SingleFile As String, MyFiles() As String, Wb As Workbook, EApp As New Application, k As Integer
MyFilePath = ThisWorkbook.Path & Application.PathSeparator
SingleFile = Dir(MyFilePath & "20130101\*.*")
Do While SingleFile <> ""
k = k + 1
ReDim Preserve MyFiles(1 To k)
MyFiles(k) = SingleFile
SingleFile = Dir
Loop
Set EApp = New Application
For k = 1 To UBound(MyFiles)
Arr0 = GetDataFromClosedFile(MyFilePath & "2012" & MyFiles(k), "Sheet1", "$B$2:$E$25")
If Arr0(1, 1) = "File Not Found.FileFullName is consist of file path and name." Then
MsgBox MyFiles(k) & " Not found in folder 2012"
GoTo 100
Else
For i = 1 To 24
Arr(i, 1) = Arr0(i, 1)
Arr(i, 2) = Arr0(i, 2)
Arr(i, 3) = Arr0(i, 3)
Arr(i, 4) = IIf(Val(Arr0(i, 3)) > 10560, 10560, IIf(Val(Arr0(i, 3)) >= 2006, Arr0(i, 3), IIf(Val(Arr0(i, 3)) <> 0, 2006, "")))
Arr(i, 5) = IIf(Val(Arr0(i, 4)) = 5, "农民工", "")
Arr(i, 6) = IIf(Val(Arr0(i, 3)) > 10560, 10560, IIf(Val(Arr0(i, 3)) >= 2006, Arr0(i, 3), IIf(Val(Arr0(i, 3)) <> 0, 2006, "")))
Next i
End If
Set Wb = EApp.Workbooks.Open(MyFilePath & "20130101" & MyFiles(k))
With Wb
.Sheets("2013").Cells(4, 3).Resize(24, 6) = Arr
.Close True
End With
100:
Erase Arr0
Erase Arr
Next
EApp.Quit
MsgBox "All documents have been updated."
End Sub

复制代码

Public Function GetDataFromClosedFile(ByVal FileFullName As String, _
ByVal SheetName As String, _
ByVal Range_Ref As String) As Variant
Dim FilePath As String, FileName As String
Dim cell As Range, i As Integer, ReturnData, Arg As String
'判断文件是否存在
If Dir(FileFullName) = "" Then
ReDim ReturnData(1 To 1, 1 To 1)
ReturnData(1, 1) = "File Not Found.FileFullName is consist of file path and name."
GoTo Exit_Function
End If
ReDim ReturnData(1 To Range(Range_Ref).Rows.Count, 1 To Range(Range_Ref).Columns.Count)
FilePath = Left(FileFullName, InStrRev(FileFullName, Application.PathSeparator))
FileName = Mid(FileFullName, InStrRev(FileFullName, Application.PathSeparator) + 1)
For Each cell In Range(Range_Ref)
Arg = "'" & FilePath & "[" & FileName & "]" & SheetName & "'!" _
& cell.Address(, , xlR1C1)
ReturnData(cell.Row - Range(Range_Ref).Row + 1, cell.Column - Range(Range_Ref).Column + 1) = _
IIf(Application.ExecuteExcel4Macro(Arg) = 0, "", Application.ExecuteExcel4Macro(Arg))
Next cell
Exit_Function:
GetDataFromClosedFile = ReturnData
End Function

复制代码

dxllxb · 发表于 2012-12-29 23:40

suye1010 发表于 2012-12-29 16:47
这个方案你看看可行？

向版主致敬，已下载测试，运行相当良好~已测试400+多文件，速度非常快，
再次感谢版主大人！！{:171:}

dxllxb · 发表于 2012-12-31 12:37

suye1010 发表于 2012-12-29 16:47
这个方案你看看可行？

版主大人，当需要导入的数据有500条的时候，我把24改成500，后面总是提示我“下标越界”提示Arr(i, 2) = Arr0(i, 2)有问题，请问如何更正呢

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