[已解决]求助各位老师 关于工作表复制

古典文学

我是初学
想实现一个功能
就是把一个文件夹里面的若干个工作薄里面的工作表（都是sheet1）
分别复制到一个工作薄里面（也是sheet1）
就是这若干个工作表分别复制到一个工作薄的工作表（就是替代原来工作表的内容）
怎么实现呢 谢谢老师

最佳答案

月排行榜 / 总排行榜

dsmch

2014-2-12 12:49

自计文件夹下的文件，在遥测文件夹下必须存在且名称相同

跳转到最佳答案楼层

tzjx200521

上个附件看看啊

古典文学

tzjx200521 发表于 2014-2-8 14:01
上个附件看看啊

谢谢老师 附近是要代码 还是我要实现的例子的情况呢
刚进论坛不久 还不懂 谅解

冥王

把一个文件夹里面的若干个工作薄里面的工作表（都是sheet1）
分别复制到一个工作薄里面（也是sheet1）

工作簿合并？

古典文学

附件里面两个工作薄
全年那个工作薄是固定的 它里面的第一个工作表叫自计
那么我还有很多跟降水量表一样的工作薄在一个文件夹里面
我想实现的时把若干个跟降水量表一样的工作薄里面的工作表（只有一个工作表）分别复制到
全年工作薄的自计工作表位置。
假如文件夹里面有10个降水量工作表（名字都会不一样），这10个工作表分别复制到全年工作薄的
自计工作表位置，然后分别生成一个新工作薄名字同于降水量表工作薄的名字。
表达有点不清晰，不知道老师们看懂没，先谢谢啦。

dsmch

古典文学 发表于 2014-2-8 14:14
附件里面两个工作薄
全年那个工作薄是固定的 它里面的第一个工作表叫自计
那么我还有很多跟降水量表一样的 ...

是不是这样？
用降水量表工作簿的表一，替换全年工作簿的表一，另存为新降水量表工作簿？

古典文学

dsmch 发表于 2014-2-8 20:20
是不是这样？
用降水量表工作簿的表一，替换全年工作簿的表一，另存为新降水量表工作簿？

今天出门了 回复晚了 不好意思老师
您理解的对的
只不过要有好几个降水量的工作薄 要逐一替换
麻烦您帮看看能不能实现下 谢谢了

tzjx200521

看不懂  后面的遥测，对照表要怎么改？？？

古典文学

tzjx200521 发表于 2014-2-9 22:27
看不懂  后面的遥测，对照表要怎么改？？？

遥测 和对照表 两个工作表就不用管啦  
就是把第一个工作表替换了就行  

tzjx200521

1. Sub Macro1()
   
2.     Dim MyPath$, MyName$, sh As Worksheet, shtyc As Worksheet, shtdc As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Set shtyc = Workbooks("全年.xlsm").Sheets("遥测")
   
5.     Set shtdc = Workbooks("全年.xlsm").Sheets("对照")
   
6.     MyPath = ThisWorkbook.Path & ""
   
7.     MyName = Dir(MyPath & "*.xls")
   
8.     Do While MyName <> ""
   
9.         If MyName <> "全年.xlsm" Then
   
10.             Workbooks.Open (MyPath & MyName)
    
11.             With GetObject(MyPath & MyName)
    
12.                 Sheets(1).Name = "自计"
    
13.                 Sheets.Add after:=Sheets("自计")
    
14.                 ActiveSheet.Name = "遥测"
    
15.                 shtyc.Cells.Copy Workbooks(MyName).Sheets("遥测").Range("a1")
    
16.                 Sheets.Add after:=Sheets("遥测")
    
17.                 ActiveSheet.Name = "对照"
    
18.                 shtdc.Cells.Copy Workbooks(MyName).Sheets("对照").Range("a1")
    
19.                 .Close True
    
20.             End With
    
21.         End If
    
22.         MyName = Dir
    
23.     Loop
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

请楼主测试下可不可以……