Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1660|回复: 2

[已解决]求助大家关于遍历复制

[复制链接]
发表于 2016-3-28 14:08 | 显示全部楼层 |阅读模式
附件数据计算文件夹内有原始数据工作薄,想实现把这个工作薄里面a1:b5的数据,分别复制到成果数据文件夹内的每一个工作薄(工作薄数量不一定,但格式一样,名称类似),设计暴雨洪水工资表,b23:c27的位置。
也就是相同的数分别复制到每一个工作薄的相同位置。
感谢各位老师帮助。
最佳答案
2016-3-28 14:39
  1. Sub 导入到指定文件夹()
  2.     arr = [a1:b5]
  3.     Dim fd As FileDialog, myPath As String, wb As Workbook
  4.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  5.     fd.InitialFileName = ThisWorkbook.Path & ""
  6.     If fd.Show = -1 Then myPath = fd.SelectedItems(1)
  7.     Set fd = Nothing
  8.     Application.Calculation = xlCalculationManual
  9.     Application.DisplayAlerts = False
  10.     If myPath <> "" Then
  11.         Set fso = CreateObject("scripting.filesystemobject")
  12.         Set ff = fso.getfolder(myPath)
  13.         On Error Resume Next
  14.         For Each f In ff.Files
  15.             Set wb = Workbooks.Open(f)
  16.             wb.Worksheets("设计暴雨洪水").[b23:c27] = arr
  17.             wb.Close True
  18.         Next
  19.     End If
  20.     Application.Calculation = xlCalculationAutomatic
  21.     Application.DisplayAlerts = True
  22. End Sub
复制代码

数据计算.rar

584.53 KB, 下载次数: 6

发表于 2016-3-28 14:39 | 显示全部楼层    本楼为最佳答案   
  1. Sub 导入到指定文件夹()
  2.     arr = [a1:b5]
  3.     Dim fd As FileDialog, myPath As String, wb As Workbook
  4.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  5.     fd.InitialFileName = ThisWorkbook.Path & ""
  6.     If fd.Show = -1 Then myPath = fd.SelectedItems(1)
  7.     Set fd = Nothing
  8.     Application.Calculation = xlCalculationManual
  9.     Application.DisplayAlerts = False
  10.     If myPath <> "" Then
  11.         Set fso = CreateObject("scripting.filesystemobject")
  12.         Set ff = fso.getfolder(myPath)
  13.         On Error Resume Next
  14.         For Each f In ff.Files
  15.             Set wb = Workbooks.Open(f)
  16.             wb.Worksheets("设计暴雨洪水").[b23:c27] = arr
  17.             wb.Close True
  18.         Next
  19.     End If
  20.     Application.Calculation = xlCalculationAutomatic
  21.     Application.DisplayAlerts = True
  22. End Sub
复制代码

数据计算.rar

598.17 KB, 下载次数: 12

回复

使用道具 举报

 楼主| 发表于 2016-3-28 14:53 | 显示全部楼层
grf1973 发表于 2016-3-28 14:39

太好了
实现了  十分感谢您
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 13:24 , Processed in 0.341229 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表